home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr53 / acmalg01.zip / ACM672.FOR < prev    next >
Text File  |  1993-01-01  |  203KB  |  5,592 lines
  1. C      ALGORITHM 672, COLLECTED ALGORITHMS FROM ACM.
  2. C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
  3. C      VOL. 15, NO. 2, PP. 137-143.
  4. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  5. C                      Demonstration driver
  6. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  7. C The following templates demonstrate the use of the procedure EXTEND
  8. C to generate sequences of extended quadrature rules for various weight
  9. C functions given the definitions of the orthogonal polynomial 3-term
  10. C recurrence relations. ICASE selects the
  11. C required sequence as follows:
  12. C    ICASE = 1    3-point Gauss-Legendre in [-1,1]
  13. C    ICASE = 2    2-point Gauss-Lobatto in [-1,1]
  14. C    ICASE = 3    6-point Radau in [-1,1]
  15. C    ICASE = 4    2-point Gauss-Laguerre in [0,infinity)
  16. C    ICASE = 5    3-point Gauss-Hermite in (-infinity,infinity)
  17. C    ICASE = 6    3-point Gauss-Jacobi in [0,1]
  18. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  19. C FORTRAN-77 code
  20. C Unless indicated otherwise the type of each variable is implied w%C by the def
  21. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  22.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  23.       PARAMETER (LDA=257,LDB=2*LDA+1,IDIGIT=8,NEXP=38,NTEST=4)
  24.       PARAMETER (ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
  25.       DOUBLE PRECISION T(0:LDA),EXT(0:LDA)
  26.       DOUBLE PRECISION QR(LDA),QI(LDA)
  27.       DOUBLE PRECISION PNODES(LDA),WT(LDA)
  28.       DOUBLE PRECISION ERR(LDA),TEST(0:NTEST)
  29.       DOUBLE PRECISION WORKA(LDA,LDA),WORKB(LDB,3)
  30.       INTEGER IWORK(LDA)
  31.       LOGICAL SYMMET,START
  32.       EXTERNAL RECURA,RECURB,RECURC,RECURD
  33. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  34. C Get data from terminal
  35. C
  36. C Select demonstration
  37. 5     WRITE(*,10)
  38. 10    FORMAT(' Case ?:')
  39.       READ(*,*)ICASE
  40.       ICASE=MAX(1,ICASE)
  41. C Select number of iterative extensions to be performed
  42.       WRITE(*,20)
  43. 20    FORMAT(' No. of rules?:')
  44.       READ(*,*)NSEQ
  45.       NSEQ=MAX(1,NSEQ)
  46.       I=1
  47. 50    GOTO(100,200,300,400,500,600),ICASE
  48. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  49. C Demonstration 1 - extension of 3-point Gauss-Legendre rule
  50. C Recurrence defined by RECURA
  51. 100   IF(I.EQ.1) THEN
  52. C Generate 3-point Gauss initially from zero point rule,
  53. C i.e. no pre-assigned nodes, symmetry exploited.
  54.         WRITE(*,*) 'Gauss-Legendre 3-point extension'
  55.         N=0
  56.         M=3
  57.         M0=0
  58.         T(0)=ONE
  59.         SYMMET=.TRUE.
  60.         START=.FALSE.
  61.       ELSE
  62. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  63. C generated in the previous cycle
  64.         M=N+1
  65.         START=.FALSE.
  66.       END IF
  67. C Calculate extension
  68.       H0=TWO
  69.       IDEG=N+2*M-1
  70.       CALL EXTEND(N,M,M0,T,RECURA,SYMMET,START,PNODES,H0,NEXP,
  71.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  72.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  73. C Tests
  74.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  75.         DO 120 K=0,MIN(NTEST,IDEG/2)
  76.           CALL CHECK(N,PNODES,WT,K,H0,RECURA,TEST(K),IERR)
  77. 120       CONTINUE
  78.       END IF
  79.       GOTO 2000
  80. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  81. C Demonstration 2 - extension of 2-point Lobatto rule
  82. C Recurrence defined by RECURA
  83. 200   IF(I.EQ.1) THEN
  84. C Add one node, Pre-assign -1.0 and 1.0, symmetry exploited.
  85.         WRITE(*,*) 'Lobatto 2-point extension'
  86.         N=2
  87.         M=1
  88.         PNODES(1)=ONE
  89.         PNODES(2)=-ONE
  90.         SYMMET=.TRUE.
  91.         START=.TRUE.
  92.       ELSE
  93. C Add N-1 nodes using the pre-assigned nodes defined by the T polynomial
  94. C generated in the previous cycle
  95.         M=N-1
  96.         START=.FALSE.
  97.       END IF
  98.       H0=TWO
  99.       IDEG=N+2*M-1
  100.       CALL EXTEND(N,M,M0,T,RECURA,SYMMET,START,PNODES,H0,NEXP,
  101.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  102.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  103. C Tests
  104.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  105.         DO 220 K=0,MIN(NTEST,IDEG/2)
  106.           CALL CHECK(N,PNODES,WT,K,H0,RECURA,TEST(K),IERR)
  107. 220       CONTINUE
  108.       END IF
  109.       GOTO 2000
  110. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  111. C Demonstration 3 - extension of 6-point Radau rule
  112. C Recurrence defined by RECURA
  113. 300   IF(I.EQ.1) THEN
  114. C Add five nodes. Pre-assign -1.0, no symmetry.
  115.         WRITE(*,*) 'Radau 6-point extension'
  116.         N=1
  117.         M=5
  118.         PNODES(1)=-ONE
  119.         SYMMET=.FALSE.
  120.         START=.TRUE.
  121.       ELSE
  122. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  123. C generated in the previous cycle
  124.         M=N+1
  125.         START=.FALSE.
  126.       END IF
  127.       H0=TWO
  128.       IDEG=N+2*M-1
  129.       CALL EXTEND(N,M,M0,T,RECURA,SYMMET,START,PNODES,H0,NEXP,
  130.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  131.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  132. C Tests
  133.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  134.         DO 320 K=0,MIN(NTEST,IDEG/2)
  135.           CALL CHECK(N,PNODES,WT,K,H0,RECURA,TEST(K),IERR)
  136. 320       CONTINUE
  137.       END IF
  138.       GOTO 2000
  139. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  140. C Demonstration 4 - extension of 2-point Gauss-Laguerre
  141. C Recurrence defined by RECURB
  142. 400   IF(I.EQ.1) THEN
  143. C Generate 2-point rule initially from zero point rule,
  144. C i.e. no pre-assigned nodes, no symmetry.
  145.         WRITE(*,*) 'Gauss-Laguerre 2-point extension'
  146.         N=0
  147.         M=2
  148.         M0=0
  149.         T(0)=ONE
  150.         SYMMET=.FALSE.
  151.         START=.FALSE.
  152.       ELSE
  153. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  154. C generated in the previous cycle
  155.         M=N+1
  156.         START=.FALSE.
  157.       END IF
  158. C Calculate extension
  159.       H0=ONE
  160.       IDEG=N+2*M-1
  161.       CALL EXTEND(N,M,M0,T,RECURB,SYMMET,START,PNODES,H0,NEXP,
  162.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  163.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  164. C Tests
  165.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  166.         DO 420 K=0,MIN(NTEST,IDEG/2)
  167.           CALL CHECK(N,PNODES,WT,K,H0,RECURB,TEST(K),IERR)
  168. 420       CONTINUE
  169.       END IF
  170.       GOTO 2000
  171. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  172. C Demonstration 5 - extension of 3-point Gauss-Hermite rule
  173. C Recurrence defined by RECURC
  174. 500   IF(I.EQ.1) THEN
  175. C Generate 3-point rule initially from zero point rule,
  176. C i.e. no pre-assigned nodes, symmetry exploited.
  177.         WRITE(*,*) 'Gauss-Hermite 3-point extension'
  178.         M=3
  179.         N=0
  180.         M0=0
  181.         T(0)=ONE
  182.         SYMMET=.TRUE.
  183.         START=.FALSE.
  184.       ELSE
  185. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  186. C generated in the previous cycle
  187.         M=N+1
  188.         START=.FALSE.
  189.       END IF
  190. C Calculate extension
  191. C Zero moment integral = sqrt(pi)
  192.       H0=TWO*SQRT(ATAN(ONE))
  193.       IDEG=N+2*M-1
  194.       CALL EXTEND(N,M,M0,T,RECURC,SYMMET,START,PNODES,H0,NEXP,
  195.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  196.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  197. C Tests
  198.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  199.         DO 520 K=0,MIN(NTEST,IDEG/2)
  200.           CALL CHECK(N,PNODES,WT,K,H0,RECURC,TEST(K),IERR)
  201. 520       CONTINUE
  202.       END IF
  203.       GOTO 2000
  204. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  205. C Demonstration 6 - extension of 3-point Gauss-Jacobi
  206. C for weight sqrt(x) in [0,1]
  207. C Recurrence defined by RECURD
  208. 600   IF(I.EQ.1) THEN
  209. C Generate 3-point rule initially from zero point rule,
  210. C i.e. no pre-assigned nodes, no symmetry.
  211.         WRITE(*,*) 'Gauss-Jacobi 3-point extension'
  212.         M=3
  213.         N=0
  214.         M0=0
  215.         T(0)=ONE
  216.         SYMMET=.FALSE.
  217.         START=.FALSE.
  218.       ELSE
  219. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  220. C generated in the previous cycle
  221.         M=N+1
  222.         START=.FALSE.
  223.       END IF
  224. C Calculate extension
  225.       H0=TWO/THREE
  226.       IDEG=N+2*M-1
  227.       CALL EXTEND(N,M,M0,T,RECURD,SYMMET,START,PNODES,H0,NEXP,
  228.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  229.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  230. C Tests
  231.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  232.         DO 620 K=0,MIN(NTEST,IDEG/2)
  233.           CALL CHECK(N,PNODES,WT,K,H0,RECURD,TEST(K),IERR)
  234. 620       CONTINUE
  235.       END IF
  236.       GOTO 2000
  237. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  238. C Display results
  239. 2000  WRITE(*,*)'Iteration',I
  240.       WRITE(*,*)'Coefficients of expansion whose roots ',
  241.      *          'are the new nodes:'
  242.       WRITE(*,3000)(EXT(J),J,J=0,M)
  243. C
  244.       WRITE(*,*)'New nodes'
  245.       WRITE(*,3100)(QR(K),QI(K),IWORK(K),ERR(K),K=1,NODES)
  246. C
  247.       WRITE(*,*)'New full extended expansion'
  248.       WRITE(*,3010)(T(J-M0),J,J=M0,N)
  249. C
  250.       WRITE(*,3200)I,N,IFLAG,NODES
  251.       IF(IFLAG.NE.0.AND.IFLAG.NE.6) THEN
  252.         WRITE(*,*)'Terminated prematurely - see IFLAG'
  253.         GOTO 5
  254.       END IF
  255. C Print rule (positive nodes only if symmetry present)
  256.       IF(SYMMET) THEN
  257.         NUM=(N+1)/2
  258.       ELSE
  259.         NUM=N
  260.       END IF
  261.       WRITE(*,3300)(J,PNODES(J),WT(J),J=1,NUM)
  262. C Display test results
  263.       DO 2010 K=0,MIN(NTEST,IDEG/2)
  264.         WRITE(*,3400)K,TEST(K)
  265. 2010    CONTINUE
  266.       IF(IFLAG.EQ.6) THEN
  267.         WRITE(*,*)'Rule test is unsatisfactory'
  268.         GOTO 5
  269.       END IF
  270.       I=I+1
  271.       IF(I.LE.NSEQ) GOTO 50
  272.       GOTO 5
  273. C
  274. 3000  FORMAT(D25.16,'*P(',I3,',X)')
  275. 3010  FORMAT(D25.16,'*P(',I3,',X)/HI')
  276. 3100  FORMAT(21X,'REAL',16X,'IMAGINARY',1X,'FLAG',7X,'ERR'/,
  277.      *                                         (2D25.16,I5,D10.1))
  278. 3200  FORMAT(' Complete extended rule: STEP=',I2,'  POINTS=',I3,
  279.      *       '  IFLAG=',I1,'  NODES ADDED=',I3)
  280. 3300  FORMAT(2X,'No.',21X,'NODE',19X,'WEIGHT',/,(I5,2D25.16))
  281. 3400  FORMAT(' TEST(',I2,')=',D25.16)
  282.       END
  283. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  284. C User defined subroutines - Recurrence relations
  285. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  286.       SUBROUTINE RECURA(K,C,D,E)
  287.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  288.       INTEGER K
  289. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  290. C Purpose:
  291. C
  292. C This is an example of a user supplied subroutine to define the
  293. C orthogonal polynomials.
  294. C
  295. C CALL RECUR(K,C,D,E) gives the coefficients C,D and E such that,
  296. C
  297. C            P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  298. C
  299. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  300. C Unless indicated otherwise the type of each variable is implied
  301. C by the default FORTRAN-77 naming convention.
  302. C
  303. C Input parameter:
  304. C K       = Index for relation
  305. C Output parameters:
  306. C C,D,E   = Parameters in the recurrence relation
  307. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  308.       PARAMETER (ZERO=0.0D0)
  309. C Legendre recurrence for [-1,1]
  310. C Covers Gauss, Lobatto and Radau
  311.       F=FLOAT(K+1)
  312.       C=FLOAT(2*K+1)/F
  313.       D=ZERO
  314.       E=-FLOAT(K)/F
  315.       RETURN
  316.       END
  317.       SUBROUTINE RECURB(K,C,D,E)
  318.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  319.       INTEGER K
  320. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  321. C Purpose: See RECURA
  322. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  323.       PARAMETER (ONE=1.0D0)
  324. C Laguerre recurrence
  325.       F=FLOAT(K+1)
  326.       C=-ONE/F
  327.       D=FLOAT(2*K+1)/F
  328.       E=-FLOAT(K)/F
  329.       RETURN
  330.       END
  331.       SUBROUTINE RECURC(K,C,D,E)
  332.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  333.       INTEGER K
  334. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  335. C Purpose: See RECURA
  336. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  337.       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
  338. C Hermite recurrence
  339.       C=ONE
  340.       D=ZERO
  341.       E=-FLOAT(K)/TWO
  342.       RETURN
  343.       END
  344.       SUBROUTINE RECURD(K,C,D,E)
  345.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  346.       INTEGER K
  347. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  348. C Purpose: See RECURA
  349. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  350.       PARAMETER (ONE=1.0D0,TWO=2.0D0,ONEP5=1.5D0)
  351. C Jacobi polynomials in [0,1]
  352. C Weight function is (1-x)**(p-q)*x**(q-1)
  353. C
  354. C Case for weight sqrt(x)   i.e. p=3/2 and q=p
  355.       P=ONEP5
  356.       Q=P
  357.       FK=FLOAT(K)
  358.       F2K=FK*TWO
  359.       B=F2K+P
  360.       BP1=B+ONE
  361.       X3=(B-TWO)*(B-ONE)*B
  362.       A1=(B-ONE)*BP1*X3
  363.       A2=-X3*(F2K*(FK+P)+Q*(P-ONE))
  364.       A3=X3*BP1*(B-ONE)
  365.       A4=FK*(FK+Q-ONE)*(FK+P-ONE)*(FK+P-Q)*BP1
  366.       C=A3/A1
  367.       D=A2/A1
  368.       E=-A4/A1
  369.       RETURN
  370.       END
  371. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  372. C        Main algorithm begins here with structure:
  373. C                     ->   ASSIGN
  374. C
  375. C                     ->   GENER  ----> EPROD
  376. C
  377. C       EXTEND -------->   SOLVE  ----> NEWTON/BAIR
  378. C         v
  379. C         v           ->   RSORT
  380. C         v
  381. C       CHECK         ->   WEIGHT
  382. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  383.       SUBROUTINE EXTEND(N,M,M0,T,RECUR,SYMMET,START,PNODES,H0,NEXP,
  384.      *                  IDIGIT,WT,NODES,QRNODE,QINODE,ERR,EXT,
  385.      *                  IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  386.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  387.       DOUBLE PRECISION T(0:*),EXT(0:*)
  388.       DOUBLE PRECISION PNODES(*),WT(*),H0
  389.       DOUBLE PRECISION QRNODE(*),QINODE(*),ERR(*)
  390.       DOUBLE PRECISION WORKA(0:LDA-1,0:*),WORKB(0:LDB-1,*)
  391.       INTEGER M0,N,M,IWORK(*),LDA,LDB,NODES,IFLAG,NEXP,IDIGIT
  392.       LOGICAL SYMMET,START
  393.       EXTERNAL RECUR
  394. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  395. C FORTRAN-77 Version 2.2: March 1987
  396. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  397. C Please address queries or comments to:
  398. C
  399. C        T.N.L. Patterson
  400. C        Department of Applied Mathematics & Theoretical Physics
  401. C        The Queen's University of Belfast
  402. C        Belfast, BT9 1NN
  403. C        N. Ireland
  404. C
  405. C        Tel: International +44 232 245133 Ext. 3792.
  406. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  407. C Purpose:
  408. C
  409. C Calculates the N+M node quadrature rule composed of N pre-assigned nod
  410. C together with M nodes chosen optimally to achieve algebraic degree of
  411. C precision of at least N+2*M-1.
  412. C
  413. C The orthogonal system of polynomials associated with the quadrature
  414. C weight is defined generally by the recurrence relation specified in th
  415. C user supplied subroutine RECUR.
  416. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  417. C Unless indicated otherwise the type of each variable is implied
  418. C by the default FORTRAN-77 naming convention.
  419. C
  420. C Input parameters:
  421. C N     = Number of pre-assigned nodes (and upper limit to the expansion
  422. C         Note that if successful this is reset to N+M on completion
  423. C         (the appropriate value for iterative use).
  424. C M     = Number of nodes to be optimally added.
  425. C M0    = Lower limit to the expansion of T. This is ignored if START
  426. C         is .TRUE. Note that if successful this is reset to M
  427. C         on completion (the appropriate value for iterative use).
  428. C T     = Array holding the coefficients TI of the polynomial whose
  429. C         roots define the N pre-assigned nodes of the quadrature
  430. C         rule and expressed as:
  431. C                  SUM (I=M0 to N) (TI/HI)*P(I,X)
  432. C         where HI is the integral of W(X)*P(I,X)**2 over the
  433. C         interval for which orthogonality with respect the weight
  434. C         W(X) is defined (moment integrals) and P(I,X) is the
  435. C         orthogonal polynomial of degree I. Element T(I-M0) holds the
  436. C         value of TI.
  437. C
  438. C         Note that T is either,
  439. C            (1) provided explicitly,
  440. C            (2) generated automatically from the N pre-assigned nodes
  441. C                given in PNODES(*) (if START is .TRUE.)
  442. C         or,
  443. C            (3) generated from a previous call to the subroutine.
  444. C         This array should be declared to have at least
  445. C         max(N-M0+1,M+1) elements in the calling program.
  446. C
  447. C         The service subroutine TRANSF can be used to transform
  448. C         the expansion to the required input form if desired
  449. C         with the parameter IFLAG set to 1.
  450. C RECUR = Name of user supplied subroutine which defines the orthogonal
  451. C         polynomials. Given K, CALL RECUR(K,C,D,E) gives
  452. C         the coefficients C,D and E such that,
  453. C                     P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  454. C           The parameters are defined as follows:
  455. C             K = Index
  456. C             C,D,E = Parameters in the recurrence relation
  457. C                                                (functions of K)
  458. C SYMMET = .FALSE. if no advantage is to be taken of symmetry, if any,
  459. C          about x=0 in the interval of integration and the
  460. C          orthogonality  weight function. Note that if symmetry in
  461. C          fact does exist setting this parameter to zero will still
  462. C          produce correct results - only efficiency is effected.
  463. C        = .TRUE. if the extended rule computations should
  464. C          exploit symmetry about x=0 in the interval of
  465. C          integration and the orthogonality  weight function.
  466. C          This reduces the size of the system of linear equations
  467. C          determining EXT by a factor of about 2 (see WORKA). If
  468. C          symmetry does not in fact exist erroneous results will be
  469. C          produced.
  470. C START  = .TRUE. then the polynomial T is generated to have
  471. C          the pre-assigned nodes (PNODES) as its roots.
  472. C        = .FALSE. then the supplied values of the coefficients
  473. C          of T are used directly (see above).
  474. C PNODES = Array holding the pre-assigned nodes. This array should
  475. C          be declared to have at least N+M elements in the calling prog
  476. C H0     = Integral of the orthogonality weight function over the
  477. C          interval of integration. Zero moment integral.
  478. C NEXP   = Largest negative decimal exponent supported on the
  479. C          computer. (Positive number - typical value 38 for VAX/VMS).
  480. C          Weights less than approximately 10**(-NEXP) are set to zero
  481. C          when the Christoffel-Darboux identity is used (N=M).
  482. C          This may be set to INT(LOG10(X1MACH(2))) where X is set to
  483. C          correspond to the appropriate precision in the PORT library.
  484. C IDIGIT = Node convergence parameter (integer greater than 0).
  485. C          An attempt is made to calculate the nodes to the maximum
  486. C          accuracy possible by the machine precision available.
  487. C          IDIGIT controls the assessment procedure to take account of
  488. C          round-off errors and specifies the number of least significan
  489. C          decimal digits that can be ignored (i.e. attributed
  490. C          to round-off) in the computed relative error. Typical
  491. C          value is 5.
  492. C IWORK  = Integer working array which should be declared in the
  493. C          calling program to have at least max(M,N) elements.
  494. C          On return IWORK provides information on the convergence
  495. C          of the nodes. See output parameters.
  496. C WORKA  = Real working matrix which should be declared in the calling
  497. C          program to have dimension at least max(M+1,N)
  498. C          by max(M+1,N+1). If SYMMET=.TRUE. (see above) the
  499. C          dimension can be reduced to max(M/2+1,N)
  500. C          by max(M/2+1,N+1).
  501. C LDA    = Number of elements in the leading dimension of WORKA
  502. C          declared in the calling program.
  503. C WORKB  = Real working matrix which should be declared in the calling
  504. C          program to have dimension at least 2*M+1 by 3.
  505. C LDB    = Number of elements in the leading dimension of WORKB
  506. C          declared in the calling program
  507. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  508. C Output parameters:
  509. C PNODES = Ordered array holding the N+M nodes of the extended
  510. C          quadrature rule made up from the original pre-assigned
  511. C          nodes and the new optimally extended nodes. These values can
  512. C          be used in subsequent iterative use of the subroutine.
  513. C WT     = Array holding the values of the quadrature weights for
  514. C          the extended rule associated with the nodes held in PNODES.
  515. C          This array should be declared to have at least N+M elements
  516. C          in the calling program.
  517. C T      = Array holding the coefficients TI of the new orthogonal
  518. C          expansion whose roots are the nodes of the extended quadratur
  519. C          (that is, the pre-assigned nodes plus the extended nodes) and
  520. C          is expressed as:
  521. C                      SUM (I=M to N+M) (TI/HI)*P(I,X)
  522. C          T(I-M) holds the value of TI.
  523. C          (For definitions see description of input argument T).
  524. C          This polynomial can be used as input for further extensions.
  525. C
  526. C          The service subroutine TRANSF can be used to remove the
  527. C          moment factors from the expansion if desired with the
  528. C          parameter IFLAG set to 0.
  529. C M0     = Lower limit defining the new orthogonal expansion T.
  530. C          (Set to M).
  531. C N      = Upper limit defining the new orthogonal expansion T.
  532. C          (Set to the original value of N+M).
  533. C NODES  = Number of extended nodes found. Normally equals M but see IFL
  534. C QRNODE = Array holding the real parts of the extended nodes (1,..,NODE
  535. C          This array should be declared to have at least M elements
  536. C          in the calling program.
  537. C QINODE = Array holding the imaginary parts of the extended
  538. C          nodes (1,..,NODES). (Hopefully these values are zero!).
  539. C          This array should be declared to have at least M elements
  540. C          in the calling program.
  541. C ERR    = Array holding a measure of the relative error in the
  542. C          nodes. This may be inspected if the convergence
  543. C          error flag has been raised (IFLAG=3) to decide if the nodes
  544. C          in question are acceptable. (ERR(*) actually gives the mean
  545. C          last correction to the quadratic factor in the generalised
  546. C          Bairstow root finder (see BAIR). This should declared in
  547. C          the calling program to have at least M elements.
  548. C EXT    = Array holding the coefficients of the polynomial whose
  549. C          roots are the  extended nodes (QRNODES(*),QINODES(*)) and
  550. C          expressed as:
  551. C                EXT =   SUM (I=0 to M) EXT(I)*P(I,X)
  552. C          This array should be declared to have at least M+1 elements
  553. C          in the calling program.
  554. C IWORK  = Node convergence flags. Elements 1 to NODES give information
  555. C          on the convergence of the roots of the polynomial EXT
  556. C          corresponding to each extended node.
  557. C          Element I = 0 Convergence of I th root satisfactory
  558. C          Element I = 1 Convergence of I th root unsatisfactory
  559. C IFLAG  = 0, No error detected
  560. C        = 1, The linear system of equations defining the polynomial
  561. C             whose roots are the extended nodes became singular or
  562. C             very  ill-conditioned.   (FATAL).
  563. C        = 2, The linear system of equations used to generate the
  564. C             polynomial T when START is .TRUE. became singular
  565. C             or very ill-conditioned. (FATAL).
  566. C        = 3, Poor convergence has been detected in the calculation
  567. C             of the roots of EXT (see above) corresponding to the new
  568. C             nodes or all nodes have not been found (M not equal
  569. C             to NODES). See also ERR(*) below.
  570. C        = 4, Possible imaginary nodes detected.
  571. C        = 5, Value of N and M incompatible for SYMMET=.TRUE.
  572. C             Both cannot be odd. (FATAL)
  573. C        = 6, Test of new quadrature rule has failed.
  574. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  575. C Library routines called: LINPACK - DGEFA, DGESL
  576. C FORTRAN-77 versions of these are included and renamed GEFA77 and GESL7
  577. C These call the BLAS routines DSCAL, IDAMAX, DAXPY and DDOT
  578. C which are renamed DSCAL7, IDAMX7, DAXPY7 and DDOT7.
  579. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  580. C Changing the precision.
  581. C
  582. C This is accomplished as follows:
  583. C (1) Amend the TYPE statements,
  584. C (2) Select an appropriate value for the NEXP argument to EXTEND.
  585. C
  586. C NOTE:
  587. C (a) All constants used are specified in PARAMETER statements at the st
  588. C     of each subprogram and,
  589. C (b) Generic names are used for all function calls.
  590. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  591.       INTEGER S
  592. C
  593.       IFLAG=0
  594.       NODES=0
  595.       IDEG=N+2*M-1
  596. C Look for incompatible values of N and M
  597.       IF(SYMMET) THEN
  598. C         Both N and M cannot be odd
  599.           IF(MOD(N,2).EQ.1.AND.MOD(M,2).EQ.1) THEN
  600.             IFLAG=5
  601.             RETURN
  602.           END IF
  603.       END IF
  604. C Generate if required the initial T polynomial corresponding to
  605. C prescribed pre-assigned nodes
  606.       IF(START .AND. N.NE.0) THEN
  607.         CALL ASSIGN(N,PNODES,IWORK,WORKA,LDA,RECUR,T,IERR)
  608.         M0=0
  609.         IF(IERR.NE.0) THEN
  610.           IFLAG=2
  611.           RETURN
  612.         END IF
  613.       END IF
  614.       NLAST=N
  615. C Generate extended expansion coefficients and overwrite T
  616.       CALL GENER(T,M0,N,M,RECUR,SYMMET,EXT,
  617.      *                          IWORK,WORKA,LDA,WORKB,LDB,IERR)
  618.       IF(IERR.NE.0) THEN
  619.         IFLAG=1
  620.         RETURN
  621.       END IF
  622. C Find extended nodes as roots of EXT(*)
  623.       CALL SOLVE(EXT,M,SYMMET,RECUR,IDIGIT,QRNODE,QINODE,
  624.      *                        NODES,ERR,IWORK,WORKB,LDB,IERR)
  625.       IF(IERR.NE.0) IFLAG=IERR+2
  626.       IF(IFLAG.NE.0) RETURN
  627. C Accumulate nodes for extended rule
  628.       DO 10 I=1,M
  629.         PNODES(NLAST+I)=QRNODE(I)
  630. 10      CONTINUE
  631. C Re-order
  632.       CALL RSORT(PNODES,N,1)
  633. C Compute weights (only for positive nodes if symmetric)
  634.       IF(SYMMET) THEN
  635.         NUM=(N+1)/2
  636.       ELSE
  637.         NUM=N
  638.       END IF
  639.       DO 20 I=1,NUM
  640.         CALL WEIGHT(T,M0,N,PNODES(I),RECUR,H0,NEXP,WT(I))
  641.         IF(SYMMET) THEN
  642.           WT(N-I+1)=WT(I)
  643.         END IF
  644. 20      CONTINUE
  645. C Test the new rule
  646.       DO 30 K=0,MIN(4,IDEG/2)
  647.         CALL CHECK(N,PNODES,WT,K,H0,RECUR,TEST,IERR)
  648.         IF(IERR.EQ.1) THEN
  649.           IFLAG=6
  650.           RETURN
  651.         END IF
  652. 30      CONTINUE
  653.       RETURN
  654.       END
  655.       SUBROUTINE CHECK(N,QNODE,WT,K,H0,RECUR,TEST,IERR)
  656.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  657.       DOUBLE PRECISION QNODE(*),WT(*),H0,TEST
  658.       INTEGER N,K,IERR
  659.       EXTERNAL RECUR
  660. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  661. C FORTRAN-77 Version 2.2: March 1987
  662. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  663. C Purpose:
  664. C
  665. C Carry out test of the given quadrature rule by computing the
  666. C appropriate integral of,
  667. C                     W(X)*P(K,X)*P(K,X)
  668. C over the region associated with the weight function W(X) and the
  669. C orthogonal polynomials P(K,X).
  670. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  671. C Unless indicated otherwise the type of each variable is implied
  672. C by the default FORTRAN-77 naming convention.
  673. C
  674. C Input parameters:
  675. C
  676. C N      = Number of nodes in the quadrature rule.
  677. C QNODE  = Array holding the N nodes.
  678. C WT     = Array holding the N weights.
  679. C K      = Index of the orthogonal polynomial whose weighted square
  680. C          is to be integrated.
  681. C H0     = Integral of the orthogonality weight function over the
  682. C          interval of integration. Zero moment integral. Note that
  683. C          P(0,X) is arbitrarily taken to be 1.0.
  684. C RECUR  = Name of the subroutine which defines the orthogonal
  685. C          polynomials. See EXTEND for a full description.
  686. C
  687. C Output parameters:
  688. C TEST   = Approximate value of the test integral normalised to
  689. C          unity. Thus, ABS(TEST-1) gives a measure of the
  690. C          quality of the calculated rule.
  691. C IERR   = 0, OK.
  692. C        = 1, Rule quality unsatisfactory
  693. C        = 2, Invalid values for input arguments
  694. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  695.       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TOL=0.0000001D0)
  696.       IERR=0
  697.       IF(K.LT.0 .OR. N.LT.1 .OR. H0.LE.ZERO) THEN
  698.         IERR=2
  699.         RETURN
  700.       END IF
  701.       TEST=ZERO
  702.       DO 30 I=1,N
  703.         P1=ONE
  704.         IF(K.EQ.0) GOTO 20
  705.         P0=ZERO
  706.         X=QNODE(I)
  707. C Calculate integrand
  708.         DO 10 J=0,K-1
  709.           CALL RECUR(J,CJ,DJ,EJ)
  710.           P=(CJ*X+DJ)*P1+EJ*P0
  711.           P0=P1
  712.           P1=P
  713. 10        CONTINUE
  714. 20      TEST=TEST+P1*P1*WT(I)
  715. 30      CONTINUE
  716.       TEST=TEST/H0
  717.       IF(K.EQ.0) RETURN
  718. C Calculate exact value
  719.       CALL RECUR(0,P,P0,P1)
  720.       DO 70 J=1,K
  721.         CALL RECUR(J,CJ,DJ,EJ)
  722.         P=-P*EJ
  723. 70      CONTINUE
  724. C Normalise result to unity
  725.       TEST=TEST*CJ/P
  726. C Test for rule quality
  727.       IF(ABS(TEST-ONE).GT.TOL) IERR=1
  728.       RETURN
  729.       END
  730.       SUBROUTINE ASSIGN(N,PNODES,IWORK,WORK,LDW,RECUR,T,IERR)
  731.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  732.       DOUBLE PRECISION PNODES(*),WORK(0:LDW-1,0:*),T(0:*)
  733.       INTEGER N,LDW,IERR,IWORK(*)
  734.       EXTERNAL RECUR
  735. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  736. C Purpose:
  737. C
  738. C Generate the initial polynomial T whose roots are the required
  739. C pre-assigned nodes
  740. C
  741. C Unless indicated otherwise the type of each variable is implied
  742. C by the default FORTRAN-77 naming convention.
  743. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  744. C Input parameters:
  745. C N      = Number of pre-assigned nodes to be used to generate T.
  746. C PNODES = Array holding N pre-assigned nodes to be be used to
  747. C          generate T.
  748. C IWORK  = Integer working array which should be declared in the
  749. C          calling program to have at least N elements.
  750. C WORK   = Real working matrix which should be declared in
  751. C          the calling program to have dimension at least N by
  752. C          N+1.
  753. C LDW    = Number of elements in the leading dimension of WORK
  754. C          declared in the calling program
  755. C RECUR  = Name of user supplied subroutine which defines the orthogonal
  756. C          polynomials. Given K, CALL RECUR(K,C,D,E) gives
  757. C          the coefficients C,D and E such that,
  758. C                      P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  759. C          The parameters are defined as follows:
  760. C             K = Index
  761. C             C,D,E = Parameters in the recurrence relation
  762. C                                              (functions of K)
  763. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  764. C Output parameters:
  765. C T      = Array holding the coefficients of the polynomial whose
  766. C          roots define the pre-assigned nodes of the quadrature
  767. C          rule and expressed as:
  768. C                  H0* SUM (I=0 to N) T(I)/HI*P(I,X)
  769. C          T(I) holds the value of TI.
  770. C          This array should be declared to have at least N+1 elements
  771. C          in the calling program.
  772. C IERR   = 0, No error detected
  773. C        = 1, The linear system of equations used to generate the
  774. C             polynomial T became singular or very ill-conditioned. (FAT
  775. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  776. C External library routines called: LINPACK - DGEFA, DGESL
  777. C FORTRAN-77 versions of these are used and renamed GEFA77 and GESL77.
  778. C Note -- These call the BLAS routines DSCAL, IDAMAX, DAXPY and DDOT
  779. C which are not renamed.
  780. C (Quadruple precision versions used for this subprogram)
  781. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  782.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  783.       IERR=0
  784. C Set up the linear system of equations
  785.       DO 20 J=1,N
  786.         X=PNODES(J)
  787.         P0=ZERO
  788.         P1=ONE
  789.         P=P1
  790.         DO 10 K=0,N
  791.           WORK(J-1,K)=P
  792.           CALL RECUR(K,C0,D0,E0)
  793.           P=(C0*X+D0)*P1+E0*P0
  794.           P0=P1
  795.           P1=P
  796. 10        CONTINUE
  797. 20      CONTINUE
  798. C Solve linear system
  799.       CALL GEFA77(WORK,LDW,N,IWORK,INFO)
  800.       IF(INFO.NE.0) THEN
  801.         IERR=1
  802.         RETURN
  803.       END IF
  804.       CALL GESL77(WORK,LDW,N,IWORK,WORK(0,N),0)
  805.       DO 30 J=0,N-1
  806.         T(J)=-WORK(J,N)
  807. 30      CONTINUE
  808.       T(N)=ONE
  809. C Weight with moments
  810.       CALL TRANSF(T,0,N,RECUR,1)
  811.       RETURN
  812.       END
  813.       SUBROUTINE GENER(T,M0,N,M,RECUR,SYMMET,EXT,
  814.      *                          IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  815.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  816.       DOUBLE PRECISION WORKA(0:LDA-1,0:*),WORKB(0:LDB-1,*)
  817.       DOUBLE PRECISION T(0:*),EXT(0:*)
  818.       INTEGER M0,N,M,IWORK(*),LDA,LDB,IFLAG
  819.       LOGICAL SYMMET
  820. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  821. C Purpose:
  822. C
  823. C Given N pre-assigned quadrature nodes defined as the roots of the
  824. C polynomial expansion,
  825. C                   SUM (I=M0 to N) (TI/HI)*P(I,X)
  826. C calculate the polynomial expansion,
  827. C                   SUM (I=0 to M) SI*P(I,X)
  828. C whose roots are the M optimal nodes and new expansion
  829. C                   SUM (I=M to N+M) (RI/HI)*P(I,X)
  830. C whose roots are to the N+M nodes of the full extended quadrature rule.
  831. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  832. C Unless indicated otherwise the type of each variable is implied
  833. C by the default FORTRAN-77 naming convention.
  834. C
  835. C Input parameters:
  836. C T     = Array holding the coefficients TI of the polynomial whose
  837. C         roots define the N pre-assigned nodes of the quadrature
  838. C         rule and expressed as:
  839. C                  SUM (I=M0 to N) (TI/HI)*P(I,X)
  840. C         where HI is the integral of W(X)*P(I,X)**2 over the
  841. C         interval for which orthogonality with respect the weight
  842. C         W(X) is defined (moment integrals) and P(I,X) is the
  843. C         orthogonal polynomial of degree I. T(I-M0) holds the
  844. C         value of TI. This array should be declared to have at least
  845. C         max(N-M0+1,M+1) elements in the calling program.
  846. C M0    = Lower limit to the expansion of T.
  847. C N     = Upper limit to expansion of T.
  848. C M     = Number of nodes to be optimally added.
  849. C RECUR = Name of user supplied subroutine which defines the orthogonal
  850. C         polynomials. Given K, CALL RECUR(K,C,D,E) gives
  851. C         the coefficients C,D and E such that,
  852. C                     P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  853. C           The parameters are defined as follows:
  854. C             K = Index
  855. C             C,D,E = Parameters in the recurrence relation
  856. C                                                (functions of K)
  857. C SYMMET=  .FALSE. if no advantage is to be taken of symmetry, if any,
  858. C          about x=0 in the interval of integration and the
  859. C          orthogonality  weight function. Note that if symmetry in
  860. C          fact does exist setting this parameter to zero will still
  861. C          produce correct results - only efficiency is effected.
  862. C       =  .TRUE. if the extended rule computations should
  863. C          exploit symmetry about x=0 in the interval of
  864. C          integration and the orthogonality  weight function.
  865. C          This reduces the size of the system of linear equations
  866. C          determining EXT by a factor of about 2 (see WORKA). If
  867. C          symmetry does not in fact exist erroneous results will be
  868. C          produced.
  869. C IWORK  = Integer working array which should be declared in the
  870. C          calling program to have at least M elements.
  871. C WORKA  = Real working matrix which should be declared in the calling
  872. C          program to have dimension at least M+1 by max(M+1,N+1).
  873. C          If SYMMET=.TRUE. (see above) the dimension can be reduced to
  874. C          M/2+1 by max(M/2+1,N/2+1).
  875. C LDA    = Number of elements in the leading dimension of WORKA
  876. C          declared in the calling program
  877. C WORKB  = Real working matrix which should be declared in the calling
  878. C          program to have at dimension at least 2*M+1 by 3.
  879. C LDB    = Number of elements in the leading dimension of WORKB
  880. C          declared in the calling program.
  881. C
  882. C Output parameters:
  883. C T      = Array holding the coefficients of the new orthogonal
  884. C          expansion whose roots are the nodes of the extended quadratur
  885. C          (that is the pre-assigned nodes plus the extended nodes).
  886. C          It is expressed as:
  887. C                  SUM (I=M to N+M) (TI/HI)*P(I,X)
  888. C          where N and M have their original values. T(I-M) holds
  889. C          the value of TI. See input argument of T for definitions.
  890. C M0,N   = Lower and upper limits defining the new orthogonal expansion
  891. C EXT    = Array holding the coefficients of the polynomial whose
  892. C          roots are the  new extended nodes and expressed as:
  893. C                EXT =   SUM (I=0 to M) EXT(I)*P(I,X)
  894. C IFLAG  = 0, No error detected
  895. C        = 1, The linear system of equations defining the polynomial
  896. C             whose roots are the extended nodes became singular or
  897. C             very  ill-conditioned.   (FATAL).
  898. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  899. C External library routines called: LINPACK - DGEFA, DGESL
  900. C FORTRAN-77 versions of these are used and renamed GEFA77 and GESL77.
  901. C Note -- These call the BLAS routines DSCAL, IDAMAX, DAXPY and DDOT
  902. C which are not renamed.
  903. C (Quadruple precision versions used for this subprogram)
  904. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  905.       LOGICAL NEVEN,MSODD,MISS
  906.       EXTERNAL RECUR
  907.       INTEGER S
  908.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  909.       IFLAG=0
  910. C Look for trivial case
  911.       IF(N.EQ.0) THEN
  912.         DO 10 I=0,M-1
  913.           EXT(I)=ZERO
  914. 10        CONTINUE
  915.         EXT(M)=ONE
  916.         T(0)=ONE
  917.         N=M
  918.         M0=M
  919.         RETURN
  920.       END IF
  921. C General case
  922.       NEVEN=MOD(N,2).EQ.0
  923.       NM=N+M
  924. C Form matrix
  925. 20    DO 60 S=0,M
  926.         MSODD=MOD(M+S,2).EQ.1
  927.         IF(NEVEN.AND.MSODD.AND.SYMMET) GOTO 60
  928.         DO 50 J=0,S
  929.           CALL EPROD(S,J,WORKB(0,1),WORKB(0,2),LDB,RECUR,IFAIL)
  930.           IF(MOD(N+S+J,2).EQ.1.AND.SYMMET) GOTO 50
  931.           IREF=S-J
  932.           ITOP=MIN(N,J+S)
  933.           IBOT=MAX(M0,IREF)
  934.           SUM=ZERO
  935.           IF(IBOT.GT.ITOP) GOTO 40
  936.           DO 30 I=IBOT,ITOP
  937.             SUM=SUM+T(I-M0)*WORKB(I-IREF,1)
  938. 30          CONTINUE
  939. 40        IF(.NOT.SYMMET) THEN
  940.             WORKA(S,J)=SUM
  941.             WORKA(J,S)=SUM
  942.             GOTO 50
  943.           END IF
  944.           IF(NEVEN) THEN
  945.             WORKA(S/2,J/2)=SUM
  946.             WORKA(J/2,S/2)=SUM
  947.           ELSE
  948.             IF(MSODD) THEN
  949.               WORKA(S/2,J/2)=SUM
  950.             ELSE
  951.               WORKA(J/2,S/2)=SUM
  952.             END IF
  953.           END IF
  954. 50        CONTINUE
  955. 60      CONTINUE
  956.       NEQ=M
  957.       IF(SYMMET) NEQ=M/2
  958. C Solve for expansion coefficients
  959.       CALL GEFA77(WORKA,LDA,NEQ,IWORK,INFO)
  960.       IF(INFO.NE.0) THEN
  961.         IFLAG=1
  962.         RETURN
  963.       END IF
  964.       CALL GESL77(WORKA,LDA,NEQ,IWORK,WORKA(0,NEQ),0)
  965. C Store expansion coefficients
  966.       DO 70 J=0,NEQ-1
  967.         EXT(J)=-WORKA(J,NEQ)
  968. 70      CONTINUE
  969.       EXT(NEQ)=ONE
  970. C Calculate new T polynomial
  971.       IF(SYMMET) GOTO 160
  972. C
  973. C Non-symmetric case
  974.       DO 140 S=M,NM
  975.         IF(S.EQ.M) GOTO 120
  976.         DO 110 J=0,M
  977.           CALL EPROD(S,J,WORKB(0,1),WORKB(0,2),LDB,RECUR,IFAIL)
  978.           IREF=S-J
  979.           ITOP=MIN(N,J+S)
  980.           IBOT=MAX(M0,IREF)
  981.           SUM=ZERO
  982.           IF(IBOT.GT.ITOP) GOTO 100
  983.           DO 90 I=IBOT,ITOP
  984.             IR=I-IREF
  985.             SUM=SUM+T(I-M0)*WORKB(I-IREF,1)
  986. 90          CONTINUE
  987. 100       WORKA(M,J)=SUM
  988. 110       CONTINUE
  989. 120     SUM=ZERO
  990.         DO 130 I=0,M
  991.           SUM=SUM+EXT(I)*WORKA(M,I)
  992. 130       CONTINUE
  993.         WORKA(M-1,S-M)=SUM
  994. 140     CONTINUE
  995. C Overwrite old values of T
  996.       DO 150 I=0,N
  997.         T(I)=WORKA(M-1,I)
  998. 150     CONTINUE
  999.       GOTO 250
  1000. C
  1001. C Symmetric case
  1002. 160   DO 210 S=M,NM
  1003.         IF(MOD(N+M+S,2).EQ.1) GOTO 210
  1004.         DO 190 J=0,M
  1005.           CALL EPROD(S,J,WORKB(0,1),WORKB(0,2),LDB,RECUR,IFAIL)
  1006.           IF(MOD(N+S+J,2).EQ.1) GOTO 190
  1007.           IREF=S-J
  1008.           ITOP=MIN(N,J+S)
  1009.           IBOT=MAX(M0,IREF)
  1010.           SUM=ZERO
  1011.           IF(IBOT.GT.ITOP) GOTO 180
  1012.           DO 170 I=IBOT,ITOP
  1013.             IR=I-IREF
  1014.             SUM=SUM+T(I-M0)*WORKB(I-IREF,1)
  1015. 170         CONTINUE
  1016. 180       WORKA(NEQ,J/2)=SUM
  1017. 190     CONTINUE
  1018.       SUM=ZERO
  1019.       DO 200 I=0,NEQ
  1020.         SUM=SUM+EXT(I)*WORKA(NEQ,I)
  1021. 200     CONTINUE
  1022.       WORKA(NEQ-1,(S-M)/2)=SUM
  1023. 210   CONTINUE
  1024. C Overwrite old values of T in full unsymmetric form
  1025.       IC=N/2
  1026.       MISS=.TRUE.
  1027.       DO 220 J=N,0,-1
  1028.         MISS=.NOT.MISS
  1029.         IF(MISS) THEN
  1030.           T(J)=ZERO
  1031.         ELSE
  1032.           T(J)=WORKA(NEQ-1,IC)
  1033.           IC=IC-1
  1034.         END IF
  1035. 220     CONTINUE
  1036. C Convert EXT to full unsymmetric form
  1037.       WORKB(M,1)=ONE
  1038.       IC=NEQ-1
  1039.       MISS=.FALSE.
  1040.       DO 230 J=M-1,0,-1
  1041.         MISS=.NOT.MISS
  1042.         IF(MISS) THEN
  1043.           WORKB(J,1)=ZERO
  1044.         ELSE
  1045.           WORKB(J,1)=EXT(IC)
  1046.           IC=IC-1
  1047.         END IF
  1048. 230     CONTINUE
  1049.       DO 240 J=0,M
  1050.         EXT(J)=WORKB(J,1)
  1051. 240     CONTINUE
  1052. C Scale new T polynomial
  1053. 250   PMAX=ZERO
  1054.       DO 260 I=0,N
  1055.         PMAX=MAX(PMAX,ABS(T(I)))
  1056. 260     CONTINUE
  1057.       DO 270 I=0,N
  1058.         T(I)=T(I)/PMAX
  1059. 270     CONTINUE
  1060.       N=NM
  1061.       M0=M
  1062.       RETURN
  1063.       END
  1064.       SUBROUTINE SOLVE(EXT,M,SYMMET,RECUR,IDIGIT,QRNODE,QINODE,
  1065.      *                 NODES,ERR,ICHECK,WORK,LDW,IERR)
  1066.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1067.       DOUBLE PRECISION EXT(0:*),WORK(0:LDW-1,*),ERR(*)
  1068.       DOUBLE PRECISION QRNODE(*),QINODE(*)
  1069.       INTEGER M,NODES,LDW,IERR,ICHECK(*),IDIGIT
  1070.       LOGICAL SYMMET,RESET
  1071.       EXTERNAL RECUR
  1072. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1073. C Purpose:
  1074. C
  1075. C Calculate the roots of the orthogonal polynomial expansion
  1076. C expressed as,
  1077. C                 SUM (I=0 to M) EXT(I)*P(I,X)
  1078. C where the array EXT holds the appropriate coefficients.
  1079. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1080. C Unless indicated otherwise the type of each variable is implied
  1081. C by the default FORTRAN-77 naming convention.
  1082. C
  1083. C Input parameters:
  1084. C EXT    = Array holding the coefficients of the polynomial whose
  1085. C          roots are required (nodes of the quadrature rule)
  1086. C          and expressed as:
  1087. C                    SUM (I=0 to M) EXT(I)*P(I,X)
  1088. C          The recurrence relation for the orthogonal polynomials
  1089. C          P(I,X) is defined by the subroutine RECUR.
  1090. C          This array should be declared to have at least M+1 elements
  1091. C          in the calling program.
  1092. C M      = Upper limit to expansion EXT (polynomial degree).
  1093. C SYMMET = .FALSE. if no advantage can be taken of symmetry
  1094. C          about x=0 in the interval of integration and the
  1095. C          orthogonality  weight function.
  1096. C        = .TRUE. if symmetry exists about x=0 in the interval of
  1097. C          integration and the orthogonality weight function.
  1098. C RECUR  = Name of user supplied subroutine which defines the orthogonal
  1099. C          polynomials. Given K, CALL RECUR(K,C,D,E) gives
  1100. C          the coefficients C,D and E such that,
  1101. C                      P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  1102. C          The parameters are defined as follows:
  1103. C             K = Index
  1104. C             C,D,E = Parameters in the recurrence relation
  1105. C                                              (functions of K)
  1106. C IDIGIT = Node convergence parameter (integer greater than 0).
  1107. C          An attempt is made to calculate the nodes to the maximum
  1108. C          accuracy possible by the machine precision available.
  1109. C          IDIGIT controls the assessment procedure to take account of
  1110. C          round-off errors and specifies the number of least significan
  1111. C          decimal digits that can be ignored (i.e. attributed
  1112. C          to round-off) in the computed relative error. Typical
  1113. C          value is 5.
  1114. C WORK   = Real working matrix which should be declared in the calling
  1115. C          program to have dimension at least M+1 by 2.
  1116. C LDW    = Number of elements in the leading dimension of WORK
  1117. C          declared in the calling program
  1118. C
  1119. C Output parameters:
  1120. C
  1121. C QRNODE = Array holding the real parts of the roots fo EXT (1,..,NODES)
  1122. C QINODE = Array holding the imaginary parts of the roots of EXT (1,..,N
  1123. C          (hopefully these values are zero!).
  1124. C NODES  = Number of extended nodes found. Normally equals M but see IER
  1125. C ICHECK = Root convergence flags. Elements 1 to NODES give information
  1126. C          on the convergence of the roots of the polynomial EXT.
  1127. C            Element I = 0 Convergence of I th root satisfactory
  1128. C            Element I = 1 Convergence of I th root unsatisfactory
  1129. C          This array should be declared to have at least M elements
  1130. C          in the calling program.
  1131. C IERR   = 0, No error detected
  1132. C        = 1, Possible imaginary nodes detected.
  1133. C        = 2, Poor convergence has been detected in the calculation
  1134. C             of the roots of EXT (see above) or all roots have not
  1135. C             been found (M not equal to NODES). See also ERR(*) below.
  1136. C ERR    = Array holding a measure of the relative error in the
  1137. C          roots. This may be inspected if the convergence
  1138. C          error flag has been raised (IERR=2) to decide if the roots
  1139. C          in question are acceptable. (ERR(*) actually gives the mean
  1140. C          last correction to the quadratic factor in the generalised
  1141. C          Bairstow root finder (see BAIR). This should declared in
  1142. C          the calling program to have at least M elements.
  1143. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1144.       PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,
  1145.      *           TWO=2.0D0,VRT1=0.0000001D0)
  1146.       NODES=0
  1147.       IERR=0
  1148. C If M is odd find and remove initial real root using NEWTON iteration
  1149. C Set WORK(*,1) to polynomial to be processed
  1150.       IF(MOD(M,2).EQ.1) THEN
  1151.         ZR1=VRT1
  1152.         CALL NEWTON(EXT,M,ZR1,RECUR,IDIGIT,WORK(0,1),ERRVAL,IFAIL)
  1153.         NODES=NODES+1
  1154.         ICHECK(NODES)=IFAIL
  1155.         ERR(NODES)=ERRVAL
  1156.         QRNODE(NODES)=ZR1
  1157.         QINODE(NODES)=ZERO
  1158.         NROOT=M-1
  1159.       ELSE
  1160.         DO 10 I=0,M
  1161.           WORK(I,1)=EXT(I)
  1162. 10        CONTINUE
  1163.         NROOT=M
  1164.       END IF
  1165.       IF(NROOT.EQ.0) GOTO 50
  1166. C Find remaining root pairs
  1167. C Calculate seed approximation for quadratic factor
  1168.       CALL RECUR(0,C0,D0,E0)
  1169.       CALL RECUR(1,C1,D1,E1)
  1170.       RT1=VRT1
  1171.       RT2=ZERO
  1172.       IF(SYMMET) RT2=-RT1
  1173.       P1A=C0*RT1+D0
  1174.       P1B=C0*RT2+D0
  1175.       P2A=(C1*RT1+D1)*P1A+E1
  1176.       P2B=(C1*RT2+D1)*P1B+E1
  1177.       DET=C0*(RT1-RT2)
  1178.       SA1=(P2A-P2B)/DET
  1179.       SA0=(P1A*P2B-P1B*P2A)/DET
  1180.       RESET=.TRUE.
  1181. C Alternate approximation which introduces small complex component
  1182.       RT1=VRT1
  1183.       RT2=VRT1
  1184.       SFA1=(C0*D1+D0*C1)/C0+TWO*C1*RT1
  1185.       SFA0=D0*D1+E1-D0*SFA1-C0*C1*(RT1*RT1+RT2*RT2)
  1186. C IP1 points to current deflated polynomial
  1187.       IP1=1
  1188.       IP2=2
  1189. 20    IF(RESET) THEN
  1190.         A2=ONE
  1191.         A1=SA1
  1192.         A0=SA0
  1193.         RESET=.FALSE.
  1194.       END IF
  1195.       CALL BAIR(NROOT,WORK(0,IP1),WORK(0,IP2),A0,A1,A2,
  1196.      *                                     RECUR,IDIGIT,ERRVAL,IFAIL)
  1197.       IF(IFAIL.NE.0) THEN
  1198. C Try again with complex components introduced
  1199.         A2=ONE
  1200.         A1=SFA1
  1201.         A0=SFA0
  1202.         RESET=.TRUE.
  1203.         CALL BAIR(NROOT,WORK(0,IP1),WORK(0,IP2),A0,A1,A2,
  1204.      *                                     RECUR,IDIGIT,ERRVAL,IFAIL)
  1205.       END IF
  1206. C Apply Bairstow to full expansion to avoid error accumulation
  1207.       CALL BAIR(M,EXT,WORK(0,IP2),A0,A1,A2,
  1208.      *                                     RECUR,IDIGIT,ERRVAL,IFAIL)
  1209. C Tidy up the quotient polynomial
  1210.       CALL QFACT(NROOT,WORK(0,IP1),WORK(0,IP2),RECUR,A1,A0,
  1211.      *                                       ZR1,ZR1,ZR1,ZR1,ZR1,ZR1)
  1212.       CALL ROOTS(A0,A1,A2,ZR1,ZI1,ZR2,ZI2,RECUR,INFO)
  1213. C Record node information
  1214.       NODES=NODES+1
  1215.       ICHECK(NODES)=IFAIL
  1216.       ERR(NODES)=ERRVAL
  1217.       QRNODE(NODES)=ZR1
  1218.       QINODE(NODES)=ZI1
  1219.       NODES=NODES+1
  1220.       ICHECK(NODES)=IFAIL
  1221.       ERR(NODES)=ERRVAL
  1222.       QRNODE(NODES)=ZR2
  1223.       QINODE(NODES)=ZI2
  1224.       NROOT=NROOT-2
  1225. C Make the deflated polynomial current
  1226.       I=IP1
  1227.       IP1=IP2
  1228.       IP2=I
  1229.       IF(NROOT.GT.0) THEN
  1230. C Scale the deflated polynomial
  1231.         PMAX=ZERO
  1232.         DO 30 I=0,NROOT
  1233.           PMAX=MAX(PMAX,ABS(WORK(I,IP1)))
  1234. 30        CONTINUE
  1235.         DO 40 I=0,NROOT
  1236.           WORK(I,IP1)=WORK(I,IP1)/PMAX
  1237. 40        CONTINUE
  1238.         GOTO 20
  1239.       END IF
  1240. C Calculation complete - Check for difficulties
  1241. C Look for poor convergence
  1242. 50    I=0
  1243.       DO 60 J=1,NODES
  1244.         I=I+ICHECK(J)
  1245. 60      CONTINUE
  1246.       IF(NODES.NE.M.OR.I.NE.0) THEN
  1247.         IERR=1
  1248.         RETURN
  1249.       END IF
  1250. C Look for possible imaginary nodes
  1251.       DO 70 J=1,NODES
  1252.         IF(QINODE(J).NE.ZERO) THEN
  1253.           IERR=2
  1254.           RETURN
  1255.         END IF
  1256. 70      CONTINUE
  1257.       RETURN
  1258.       END
  1259.       SUBROUTINE RSORT(A,N,IFLAG)
  1260.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1261.       DOUBLE PRECISION A(*)
  1262.       INTEGER N,IFLAG
  1263. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1264. C FORTRAN-77 Version 2.2: March 1987
  1265. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1266. C Purpose:
  1267. C Carries out a simple ripple sort of A(*).
  1268. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1269. C Unless indicated otherwise the type of each variable is implied
  1270. C by the default FORTRAN-77 naming convention.
  1271. C
  1272. C Input parameters:
  1273. C A     = Array holding the numbers to be sorted
  1274. C N     = Number of elements to be sorted
  1275. C IFLAG = 0 for ascending sort
  1276. C       = 1 for descending sort
  1277. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1278.       LOGICAL DONE,ASCEND
  1279.       ASCEND=IFLAG.EQ.0
  1280. C Begin scans
  1281.       DO 30 J=N-1,1,-1
  1282.         DONE=.TRUE.
  1283.         DO 20 K=1,J
  1284.           IF(ASCEND) THEN
  1285.             K1=K
  1286.             K2=K+1
  1287.           ELSE
  1288.             K1=K+1
  1289.             K2=K
  1290.           END IF
  1291.           IF(A(K1).GT.A(K2)) THEN
  1292. C Exchange elements
  1293.             VAL=A(K1)
  1294.             A(K1)=A(K2)
  1295.             A(K2)=VAL
  1296.             DONE=.FALSE.
  1297.           END IF
  1298. 20        CONTINUE
  1299.         IF(DONE) RETURN
  1300. 30    CONTINUE
  1301.       RETURN
  1302.       END
  1303.       SUBROUTINE WEIGHT(T,M,N,XNODE,RECUR,H0,NEXP,WT)
  1304.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1305.       DOUBLE PRECISION T(0:*),XNODE,H0,WT
  1306.       INTEGER M,N,NEXP
  1307.       EXTERNAL RECUR
  1308. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1309. C FORTRAN-77 Version 2.2: March 1987
  1310. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1311. C Purpose:
  1312. C
  1313. C Calculates the quadrature weight associated with the node XNODE in the
  1314. C rule whose nodes are defined by the roots of polynomial T.
  1315. C
  1316. C The weight is calculated by dividing T by (X-XNODE) to give,
  1317. C
  1318. C S(X) = T(X)/(X-XNODE) = SUM (0 to N-1) G(I)*P(I,X).
  1319. C
  1320. C S(X) is then divided by (X-XNODE) to give remainder R.
  1321. C
  1322. C The weight is finally given by H0*G(0)/R. If N=M the
  1323. C Christoffel-Darboux identity result is used to reduce extreme
  1324. C cancellation effects at high degree.
  1325. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1326. C Unless indicated otherwise the type of each variable is implied
  1327. C by the default FORTRAN-77 naming convention.
  1328. C
  1329. C Input parameters:
  1330. C
  1331. C T      = Array holding the coefficients TI of the polynomial whose
  1332. C          roots define the N pre-assigned nodes of the quadrature
  1333. C          rule and expressed as:
  1334. C                   SUM (I=M to N) (TI/HI)*P(I,X)
  1335. C          where HI is the integral of W(X)*P(I,X)**2 over the
  1336. C          interval for which orthogonality with respect the weight
  1337. C          W(X) is defined (moment integrals) and P(I,X) is the
  1338. C          orthogonal polynomial of degree I. T(I-M) holds the
  1339. C          value of TI. This array should be declared to have at least
  1340. C          N-M+1 elements in the calling program.
  1341. C M      = Lower limit to the expansion of T
  1342. C N      = Upper limit to expansion of T
  1343. C XNODE  = Node whose weight is required
  1344. C RECUR  = Name of the subroutine which defines the orthogonal
  1345. C          polynomials. See EXTEND for a full description.
  1346. C H0     = Integral of the orthogonality weight function over the
  1347. C          interval of integration. Zero moment integral. Note that
  1348. C          P(0,X) is arbitrarily taken to be 1.0
  1349. C NEXP   = Largest negative decimal exponent supported on the
  1350. C          computer. (Positive number - typical value 38).
  1351. C          Weights less than approximately 10**(-NEXP) are set to zero
  1352. C          when the Christoffel-Darboux identity is used (N=M).
  1353. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1354. C Output parameters:
  1355. C WT    = Weight associated with XNODE.
  1356. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1357.       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TEN=10.0D0)
  1358. C Check for special case
  1359.       IF(M.EQ.N) THEN
  1360. C Use Christoffel-Darboux result
  1361.         BK1=ZERO
  1362.         BK2=ONE
  1363.         DK1=ZERO
  1364.         DK2=ZERO
  1365.         ISCALE=0
  1366.         CALL RECUR(0,H,D0,E0)
  1367.         DO 20 K=0,N-1
  1368.           CALL RECUR(K,CK,DK,EK)
  1369.           IF(K.NE.0) H=-EK*H
  1370.           BB=(CK*XNODE+DK)*BK2+EK*BK1
  1371.           DD=(CK*XNODE+DK)*DK2+EK*DK1+CK*BK2
  1372.           BK1=BK2
  1373.           BK2=BB
  1374.           DK1=DK2
  1375.           DK2=DD
  1376.           IF(BK2.NE.ZERO) THEN
  1377.             J=LOG10(ABS(BK2))
  1378.             IF(ABS(J).GT.2) THEN
  1379. C Scale to control overflow/underflow
  1380.               ISCALE=ISCALE-2*J
  1381.               SCALE=TEN**J
  1382.               BK2=BK2/SCALE
  1383.               BK1=BK1/SCALE
  1384.               DK1=DK1/SCALE
  1385.               DK2=DK2/SCALE
  1386.             END IF
  1387.           END IF
  1388.           IF(H.NE.ZERO) THEN
  1389.             J=LOG10(ABS(H))
  1390.             IF(ABS(J).GE.2) THEN
  1391.               ISCALE=ISCALE+J
  1392.               H=H/TEN**J
  1393.             END IF
  1394.           END IF
  1395. 20        CONTINUE
  1396.         WT=H0*H/DK2/BK1
  1397.         IF(WT.NE.ZERO) THEN
  1398.           ITEST=LOG10(ABS(WT))+ISCALE
  1399.           IF(ITEST.GE.-NEXP) THEN
  1400.             WT=WT*TEN**ISCALE
  1401.           ELSE
  1402.             WT=ZERO
  1403.           END IF
  1404.         END IF
  1405.         RETURN
  1406.       END IF
  1407. C General case
  1408.       BK2=ZERO
  1409.       BK1=ZERO
  1410.       RK2=ZERO
  1411.       RK1=ZERO
  1412.       CALL RECUR(N,CK,DK,EK)
  1413.       CALL RECUR(N+1,CK1,DK1,EK1)
  1414.       H=ONE
  1415.       ISCALE=0
  1416.       DO 10 K=N,1,-1
  1417.         IF(K.GE.M) THEN
  1418.           RS=T(K-M)/H
  1419. C Scale and adjust for possible overflow/underflow
  1420.           IF(ISCALE.GT.NEXP) THEN
  1421.             RS=ZERO
  1422.           ELSE
  1423.             RS=RS/TEN**ISCALE
  1424.           END IF
  1425.         ELSE
  1426.           RS=ZERO
  1427.         END IF
  1428.         BB=RS+(DK+XNODE*CK)*BK1+EK1*BK2
  1429.         BK2=BK1
  1430.         BK1=BB
  1431.         CALL RECUR(K-1,CKM1,DKM1,EKM1)
  1432.         IF(N.NE.M) H=-H*CK/EK/CKM1
  1433.         BB=BB*CKM1
  1434.         WT=BB+(DKM1+XNODE*CKM1)*RK1+EK*RK2
  1435.         RK2=RK1
  1436.         RK1=WT
  1437.         CK1=CK
  1438.         DK1=DK
  1439.         EK1=EK
  1440.         CK=CKM1
  1441.         DK=DKM1
  1442.         EK=EKM1
  1443.         IF(BK1.NE.ZERO) THEN
  1444.           J=LOG10(ABS(BK1))
  1445.           IF(ABS(J).GT.2) THEN
  1446. C Scale to control overflow/underflow
  1447.             ISCALE=ISCALE+J
  1448.             SCALE=TEN**J
  1449.             BK1=BK1/SCALE
  1450.             BK2=BK2/SCALE
  1451.             RK1=RK1/SCALE
  1452.             RK2=RK2/SCALE
  1453.           END IF
  1454.         END IF
  1455. 10      CONTINUE
  1456.       WT=H0*BB/WT
  1457.       RETURN
  1458.       END
  1459.       SUBROUTINE TRANSF(T,M,N,RECUR,IFLAG)
  1460.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1461.       DOUBLE PRECISION T(0:*)
  1462.       INTEGER M,N
  1463.       EXTERNAL RECUR
  1464. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1465. C FORTRAN-77 Version 2.2: March 1987
  1466. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1467. C Purpose:
  1468. C
  1469. C Scales the polynomial expansion:
  1470. C          SUM (M to N) TI*P(I,X).
  1471. C with respect to the moments HI of the orthogonality weight function
  1472. C giving the expansion:
  1473. C          H0* SUM (M to N) (TI/HI)*P(I,X).
  1474. C or
  1475. C      (1/H0)* SUM (M to N) (TI*HI)*P(I,X).
  1476. C depending on the value of IFLAG.
  1477. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1478. C Unless indicated otherwise the type of each variable is implied
  1479. C by the default FORTRAN-77 naming convention.
  1480. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1481. C Input parameters:
  1482. C
  1483. C T      = Array holding the coefficients TI of the polynomial expansion
  1484. C          to be scaled and expressed as:
  1485. C                   SUM (I=M to N) TI*P(I,X)
  1486. C          T(I-M) holds the value of TI. T(*) should be declared to
  1487. C          have at least N-M+1 elements in the calling program.
  1488. C M      = Lower limit to the expansion of T
  1489. C N      = Upper limit to expansion of T
  1490. C RECUR  = Name of the subroutine which defines the orthogonal
  1491. C          polynomials. See EXTEND for a full description.
  1492. C IFLAG  = 0, if coefficient TI is to be replaced by TI*(H0/HI).
  1493. C IFLAG  = 1, if coefficient TI is to be replaced by TI*(HI/H0).
  1494. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1495. C Output parameters:
  1496. C T      = Array holding the coefficients of the scaled polynomial
  1497. C          expansion.
  1498. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1499.       PARAMETER (ONE=1.0D0)
  1500.       H=ONE
  1501.       DO 10 K=0,N
  1502.         CALL RECUR(K,CK,DK,EK)
  1503.         IF(K.NE.0) H=-CKM1/CK*EK*H
  1504.         IF(K.GE.M) THEN
  1505.           IF(IFLAG.EQ.0) THEN
  1506.             T(K-M)=T(K-M)/H
  1507.           ELSE
  1508.             T(K-M)=T(K-M)*H
  1509.           END IF
  1510.         END IF
  1511.         CKM1=CK
  1512. 10      CONTINUE
  1513.       RETURN
  1514.       END
  1515.       SUBROUTINE BAIR(N,POLIN,POLOUT,A0,A1,A2,RECUR,IDIGIT,ERRVAL,IFAIL)
  1516.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1517.       DOUBLE PRECISION POLIN(0:*),POLOUT(0:*),A0,A1,A2,ERRVAL
  1518.       INTEGER N,IDIGIT,IFAIL
  1519.       EXTERNAL RECUR
  1520. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1521. C FORTRAN-77 Version 2.2: March 1987
  1522. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1523. C Purpose:
  1524. C
  1525. C Generalised Bairstow root extraction for polynomial
  1526. C        SUM(I=0 to N)  POLIN(I)*P(I,X)
  1527. C Calculates root as quadratic factor,
  1528. C        A2*P(2,X)-A1*P(1,X)-A0*P(0,X)
  1529. C where P(I,X) is a general orthogonal polynomial of degree I
  1530. C
  1531. C (Reference: Golub & Robertson, Comm.ACM.,10,1967,371-373).
  1532. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1533. C Unless indicated otherwise the type of each variable is implied
  1534. C by the default FORTRAN-77 naming convention.
  1535. C
  1536. C Input parameters:
  1537. C
  1538. C N        = Degree of input polynomial POLIN
  1539. C POLIN    = Coefficients of polynomial of degree N whose quadratic
  1540. C            factor is to be found, i.e.
  1541. C                POLIN = SUM(I=0 to N) POLIN(I)*P(I,X)
  1542. C            This array should be declared to have at least N+1 elements
  1543. C            in the calling program.
  1544. C A0,A1,A2 = Estimated quadratic factors
  1545. C RECUR    = Name of the subroutine which defines the orthogonal
  1546. C            polynomials. See EXTEND for full description.
  1547. C IDIGIT   = Node convergence parameter (integer greater than 0).
  1548. C            An attempt is made to calculate the nodes to the maximum
  1549. C            accuracy possible by the machine precision available.
  1550. C            IDIGIT controls the assessment procedure to take account of
  1551. C            round-off errors and specifies the number of least signific
  1552. C            decimal digits that can be ignored (i.e. attributed
  1553. C            to round-off) in the computed relative error. Typical
  1554. C            value is 5.
  1555. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1556. C Output parameters:
  1557. C
  1558. C POLOUT   = Coefficients of the deflated polynomial of degree N-2 with
  1559. C            quadratic factor removed, i.e.
  1560. C                POLOUT = SUM(I=0 to N-2) POLOUT(I)*P(I,X)
  1561. C            This array should be declared to have at least N-1 elements
  1562. C            in the calling program.
  1563. C A0,A1,A2 = Calculated coefficients of the quadratic factor
  1564. C IFAIL    = 0 Quadratic factor found.
  1565. C          = 1 Convergence not achieved after 50 iterations.
  1566. C ERRVAL   = Mean value of the correction to the coefficients of
  1567. C            the quadratic factor. May be used as a measure of the
  1568. C            root accuracy when convergence is not achieved.
  1569. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1570.       PARAMETER (ZERO=0.0D0,HALF=0.5D0,ONE=1.0D0,TEN=10.0D0)
  1571.       IFAIL=0
  1572.       ITER=50
  1573.       ERRVAL=ZERO
  1574. C Special cases
  1575.       IF(N.EQ.1) THEN
  1576.         A0=-POLIN(0)
  1577.         A1=-POLIN(1)
  1578.         A2=ZERO
  1579.         RETURN
  1580.       END IF
  1581.       IF(N.EQ.2) THEN
  1582.         A0=-POLIN(0)
  1583.         A1=-POLIN(1)
  1584.         A2= POLIN(2)
  1585.         RETURN
  1586.       END IF
  1587. C Estimated ALPHA & BETA
  1588.       TOL=TEN**(-MAX(1,IDIGIT))
  1589.       ALPHA=A1/A2
  1590.       BETA=A0/A2
  1591. 10    ITER=ITER-1
  1592.       IF(ITER.LT.0) THEN
  1593.         IFAIL=1
  1594.         GOTO 20
  1595.       END IF
  1596.       CALL QFACT(N,POLIN,POLOUT,RECUR,ALPHA,BETA,A,B,AA,AB,BA,BB)
  1597.       SCALE=MAX(ABS(AB),ABS(BB))
  1598.       F1=AB/SCALE
  1599.       F2=BB/SCALE
  1600.       DELTA=(B*F1-A*F2)/(AA*F2-BA*F1)
  1601.       SCALE=MAX(ABS(BA),ABS(AA))
  1602.       F1=BA/SCALE
  1603.       F2=AA/SCALE
  1604.       EPS=(A*F1-B*F2)/(BB*F2-AB*F1)
  1605.       ALPHA=ALPHA+DELTA
  1606.       BETA=BETA+EPS
  1607. C Test for convergence
  1608. C Stop if correction is less than 1/TOL times the smallest machine
  1609. C relative error.
  1610.       IF(ABS(ALPHA)+TOL*ABS(DELTA).NE.ABS(ALPHA)
  1611.      *               .OR. ABS(BETA)+TOL*ABS(EPS).NE.ABS(BETA)) GOTO 10
  1612. C Final iteration to tidy up result
  1613.       CALL QFACT(N,POLIN,POLOUT,RECUR,ALPHA,BETA,A,B,AA,AB,BA,BB)
  1614.       SCALE=MAX(ABS(AB),ABS(BB))
  1615.       F1=AB/SCALE
  1616.       F2=BB/SCALE
  1617.       DELTA=(B*F1-A*F2)/(AA*F2-BA*F1)
  1618.       SCALE=MAX(ABS(BA),ABS(AA))
  1619.       F1=BA/SCALE
  1620.       F2=AA/SCALE
  1621.       EPS=(A*F1-B*F2)/(BB*F2-AB*F1)
  1622.       ALPHA=ALPHA+DELTA
  1623.       BETA=BETA+EPS
  1624. 20    A0=BETA
  1625.       A1=ALPHA
  1626.       A2=ONE
  1627.       ERRVAL=HALF*(ABS(EPS)+ABS(DELTA))
  1628.       RETURN
  1629.       END
  1630.       SUBROUTINE QFACT(N,GAMMA,DELTA,RECUR,ALPHA,BETA,A,B,AA,AB,BA,BB)
  1631.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1632.       DOUBLE PRECISION GAMMA(0:*),DELTA(0:*),ALPHA,BETA,A,B,AA,AB,BA,BB
  1633.       INTEGER N
  1634.       EXTERNAL RECUR
  1635. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1636. C FORTRAN-77 Version 2.2: March 1987
  1637. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1638. C Purpose:
  1639. C
  1640. C Divide the polynomial SUM(I=0 to N) GAMMA(I)*P(I,X)
  1641. C by the quadratic factor, P(2,X)-ALPHA*P(1,X)-BETA*P(0,X)
  1642. C giving the quotient SUM(I=0 to N-2) DELTA(I)*P(I,X)
  1643. C and remainder A*P(1,X)+B*P(0,X) where P(I,X) is the orthogonal
  1644. C polynomial of degree I defined by RECUR.
  1645. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1646. C Unless indicated otherwise the type of each variable is implied
  1647. C by the default FORTRAN-77 naming convention.
  1648. C
  1649. C Input parameters:
  1650. C
  1651. C N          = Degree of GAMMA
  1652. C GAMMA      = Polynomial to be divided by quadratic factor
  1653. C ALPHA,BETA = Coefficients of quadratic factor
  1654. C RECUR      = Name of the subroutine which defines the orthogonal
  1655. C              polynomials. See EXTEND for a full description.
  1656. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1657. C Output parameters:
  1658. C
  1659. C DELTA = Quotient polynomial of degreee N-2
  1660. C A,B   = Remainder coefficients
  1661. C AA    = Partial of A with respect to ALPHA
  1662. C AB    = Partial of A with respect to BETA
  1663. C BA    = Partial of B with respect to ALPHA
  1664. C BB    = Partial of B with respect to BETA
  1665. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1666.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  1667. C Initialise coefficients
  1668.       DNP2=ZERO
  1669.       DNP1=ZERO
  1670.       DN  =ZERO
  1671.       DNM1=ZERO
  1672. C Partial coefficients wrt ALPHA
  1673.       ADNP2=ZERO
  1674.       ADNP1=ZERO
  1675.       ADN  =ZERO
  1676.       ADNM1=ZERO
  1677. C Partial coefficients wrt BETA
  1678.       BDNP2=ZERO
  1679.       BDNP1=ZERO
  1680.       BDN  =ZERO
  1681.       BDNM1=ZERO
  1682. C
  1683. C Scaling parameters
  1684.       SN1=ONE
  1685.       SN2=ONE
  1686.       SN3=ONE
  1687.       SN4=ONE
  1688.       CALL RECUR(0,C0,D0,E0)
  1689.       CALL RECUR(1,C1,D1,E1)
  1690.       CALL RECUR(2,C2,D2,E2)
  1691.       CALL RECUR(3,C3,D3,E3)
  1692.       R0=-C0*E1/C1
  1693.       R1=-C0*E2/C2
  1694.       R2=-C0*E3/C3
  1695.       VM1=D0-C0*D1/C1
  1696.       VM2=D0-C0*D2/C2
  1697.       W0=-R1*E1
  1698.       W1=-C1*R2*E2/C2
  1699.       V1=D1*R1-C1*VM2*E2/C2-C1*R1*D1/C1
  1700.       K=N-2
  1701.       CALL RECUR(K+4,CK4,DK4,EK4)
  1702.       CALL RECUR(K+3,CK3,DK3,EK3)
  1703.       CALL RECUR(K+2,CK2,DK2,EK2)
  1704.       CALL RECUR(K+1,CK1,DK1,EK1)
  1705.       VLK4=C0/CK3
  1706.       VLK3=C0/CK2
  1707.       VLK2=C0/CK1
  1708.       RK3=-C0*EK4/CK4
  1709.       RK2=-C0*EK3/CK3
  1710.       VMK3=D0-DK3*VLK4
  1711.       VMK2=D0-DK2*VLK3
  1712. C Extract quadratic factor and find partial derivatives
  1713.       DO 100 K=N-2,0,-1
  1714.         CALL RECUR(K,CK,DK,EK)
  1715.         VLK1=C0/CK
  1716.         RK1=-C0*EK2/CK2
  1717.         VMK1=D0-DK1*VLK2
  1718.         SK2=C1*VLK1*VLK2/C0
  1719.         TK2=VLK2*(D1-C1*DK2/CK2)+C1*VMK1/CK1
  1720.         UK2=D1*VMK2+E1-C1*VLK3*EK3/CK3-C1*VMK2*DK2/CK2+C1*RK1/CK1
  1721.         VK2=D1*RK2-C1*VMK3*EK3/CK3-C1*RK2*DK2/CK2
  1722.         WK2=-C1*RK3*EK3/CK3
  1723.         CF1=(ALPHA*VLK2-TK2)/SN1
  1724.         CF2=(BETA+ALPHA*VMK2-UK2)/SN2
  1725.         CF3=(ALPHA*RK2-VK2)/SN3
  1726.         CF4=-WK2/SN4
  1727.         RS=GAMMA(K+2)
  1728. 40      D=RS+CF1*DNM1+CF2*DN+CF3*DNP1+CF4*DNP2
  1729.         DELTA(K)=D/SK2
  1730. 80      DA=VLK2*DNM1/SN1+VMK2*DN/SN2+RK2*DNP1/SN3
  1731.      *      + CF1*ADNM1+CF2*ADN+CF3*ADNP1+CF4*ADNP2
  1732.         DB=DN/SN2+CF1*BDNM1+CF2*BDN+CF3*BDNP1+CF4*BDNP2
  1733. C Recycle old values
  1734.         SN4=SN3
  1735.         SN3=SN2
  1736.         SN2=SN1
  1737.         SN1=SK2
  1738.         DNP2=DNP1
  1739.         DNP1=DN
  1740.         DN=DNM1
  1741.         DNM1=D
  1742.         ADNP2=ADNP1
  1743.         ADNP1=ADN
  1744.         ADN=ADNM1
  1745.         ADNM1=DA
  1746.         BDNP2=BDNP1
  1747.         BDNP1=BDN
  1748.         BDN=BDNM1
  1749.         BDNM1=DB
  1750.         CK4=CK3
  1751.         CK3=CK2
  1752.         CK2=CK1
  1753.         CK1=CK
  1754.         DK4=DK3
  1755.         DK3=DK2
  1756.         DK2=DK1
  1757.         DK1=DK
  1758.         EK4=EK3
  1759.         EK3=EK2
  1760.         EK2=EK1
  1761.         EK1=EK
  1762.         VLK4=VLK3
  1763.         VLK3=VLK2
  1764.         VLK2=VLK1
  1765.         RK3=RK2
  1766.         RK2=RK1
  1767.         VMK3=VMK2
  1768.         VMK2=VMK1
  1769. 100     CONTINUE
  1770.       CF1=ALPHA
  1771.       CF2=BETA+ALPHA*VM1-R1
  1772.       CF3=ALPHA*R1-V1
  1773.       CF4=-W1
  1774.       CF5=ALPHA*R0
  1775.       RS0=GAMMA(0)
  1776.       RS1=GAMMA(1)
  1777.       DNM1=DNM1/SN1
  1778.       DN=DN/SN2
  1779.       DNP1=DNP1/SN3
  1780.       DNP2=DNP2/SN4
  1781.       ADNM1=ADNM1/SN1
  1782.       ADN=ADN/SN2
  1783.       ADNP1=ADNP1/SN3
  1784.       ADNP2=ADNP2/SN4
  1785.       BDNM1=BDNM1/SN1
  1786.       BDN=BDN/SN2
  1787.       BDNP1=BDNP1/SN3
  1788.       BDNP2=BDNP2/SN4
  1789. C Remainder
  1790.       A=RS1+CF1*DNM1+CF2*DN+CF3*DNP1+CF4*DNP2
  1791.       B=RS0+BETA*DNM1+CF5*DN-W0*DNP1
  1792. C Partials
  1793.       AA=DNM1+VM1*DN+R1*DNP1+CF1*ADNM1+CF2*ADN+CF3*ADNP1+CF4*ADNP2
  1794.       AB=DN+CF1*BDNM1+CF2*BDN+CF3*BDNP1+CF4*BDNP2
  1795.       BA=R0*DN+BETA*ADNM1+CF5*ADN-W0*ADNP1
  1796.       BB=DNM1+BETA*BDNM1+CF5*BDN-W0*BDNP1
  1797.       RETURN
  1798.       END
  1799.       SUBROUTINE ROOTS(A0,A1,A2,ZREAL1,ZIMAG1,ZREAL2,ZIMAG2,RECUR,INFO)
  1800.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1801.       DOUBLE PRECISION A0,A1,A2,ZREAL1,ZIMAG1,ZREAL2,ZIMAG2
  1802.       INTEGER INFO
  1803.       EXTERNAL RECUR
  1804. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1805. C FORTRAN-77 Version 2.2: March 1987
  1806. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1807. C Purpose:
  1808. C
  1809. C Calculates the roots corresponding to the quadratic factor
  1810. C        A2*P(2,X)-A1*P(1,X)-A0*P(0,X)
  1811. C where P(I,X) is a general orthogonal polynomial of degree I
  1812. C defined by the recurrence calculated by subroutine RECUR.
  1813. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1814. C Unless indicated otherwise the type of each variable is implied
  1815. C by the default FORTRAN-77 naming convention.
  1816. C
  1817. C Input parameters:
  1818. C   A0,A1,A2 = Coefficients of quadratic factor
  1819. C   RECUR    = Name of the subroutine which defines the orthogonal
  1820. C              polynomials. See EXTEND for full description.
  1821. C
  1822. C Output parameters:
  1823. C   ZREAL1   = Real part of root 1
  1824. C   ZIMAG1   = Imaginary part of root 1
  1825. C   ZREAL2   = Real part of root 2
  1826. C   ZIMAG2   = Imaginary part of root 2
  1827. C   INFO     = 0 Two roots found
  1828. C            = 1 One root only (A2=0)
  1829. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1830.       PARAMETER (ZERO=0.0D0,HALF=0.5D0,FOUR=4.0D0)
  1831.       INFO=0
  1832. C
  1833.       CALL RECUR(0,C0,D0,E0)
  1834.       IF(A2.EQ.ZERO) THEN
  1835.         ZREAL1=-(A0+A1*D0)/A1/C0
  1836.         ZREAL2=ZERO
  1837.         ZIMAG1=ZERO
  1838.         ZIMAG2=ZERO
  1839.         INFO=1
  1840.         RETURN
  1841.       END IF
  1842.       CALL RECUR(1,C1,D1,E1)
  1843.       AA=-C0*C1*A2
  1844.       BB=-A2*(C0*D1+D0*C1)+C0*A1
  1845.       CC=-D0*D1*A2-E1*A2+A0+A1*D0
  1846.       Z=BB*BB-FOUR*AA*CC
  1847.       ZR=SQRT(ABS(Z))
  1848.       IF(Z.GE.ZERO) THEN
  1849.         ZIMAG1=ZERO
  1850.         ZIMAG2=ZERO
  1851.         ZREAL1=HALF*(-BB-SIGN(ZR,BB))/AA
  1852.         ZREAL2=CC/AA/ZREAL1
  1853.       ELSE
  1854.         ZREAL1=-HALF*BB/AA
  1855.         ZREAL2=ZREAL1
  1856.         ZIMAG1=HALF*ZR/AA
  1857.         ZIMAG2=-ZIMAG1
  1858.       END IF
  1859.       END
  1860.       SUBROUTINE NEWTON(T,N,XNODE,RECUR,IDIGIT,DELTA,ERRVAL,IFAIL)
  1861.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1862.       DOUBLE PRECISION T(0:*),DELTA(0:*)
  1863.       DOUBLE PRECISION XNODE,ERRVAL
  1864.       INTEGER N,IDIGIT
  1865.       EXTERNAL RECUR
  1866. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1867. C FORTRAN-77 Version 2.2: March 1987
  1868. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1869. C Purpose:
  1870. C
  1871. C Applies Newton's method to find a single root of the
  1872. C polynomial T expressed as:
  1873. C                  T =   SUM (I=0 to N) T(I)*P(I,X)
  1874. C where P(I,X) are the orthogonal polymonials whose recurrence
  1875. C relation is defined by RECUR.
  1876. C
  1877. C The value of T is found from the remainder when T is divided
  1878. C by (X-XNODE). The derivative (of the remainder) is
  1879. C calculated simultaneously. The deflated polynomial
  1880. C              DELTA = SUM (I=0 to N-1) DELTA(I)*P(I,X)
  1881. C is also computed.
  1882. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1883. C Unless indicated otherwise the type of each variable is implied
  1884. C by the default FORTRAN-77 naming convention.
  1885. C
  1886. C Input parameters:
  1887. C
  1888. C T      = Polynomial whose roots define the nodes of the quadrature rul
  1889. C          and expressed as:
  1890. C                  T =   SUM (I=0 to N) T(I)*P(I,X)
  1891. C          This array should be declared to have at least N+1 elements
  1892. C          in the calling program.
  1893. C N      = Degree of the expansion of T.
  1894. C XNODE  = Approximation to root
  1895. C RECUR  = Name of the subroutine which defines the orthogonal
  1896. C          polynomials. See EXTEND for a full description.
  1897. C IDIGIT = Node convergence paramter (integer greater than 0).
  1898. C          An attempt is made to calculate the nodes to the maximum
  1899. C          accuracy possible by the machine precision available.
  1900. C          IDIGIT controls the assessment procedure to take account of
  1901. C          round-off errors and specifies the number of least significan
  1902. C          decimal digits that can be ignored (i.e. attributed
  1903. C          to round-off) in the computed relative error. Typical
  1904. C          value is 5.
  1905. C
  1906. C Output parameters:
  1907. C
  1908. C XNODE  = Required root.
  1909. C DELTA  = Array holding the coefficients of the deflated polynomial
  1910. C          of degree N-1. This array should be declared to have at
  1911. C          least N elements in the calling program.
  1912. C ERRVAL = Value of the correction. May be used as a measure of the
  1913. C          root accuracy when convergence is not achieved.
  1914. C IFAIL  = 0, Convergence OK.
  1915. C        = 1, Unsatisfactory convergence after 50 iterations.
  1916. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1917.       PARAMETER (TEN=10.0D0)
  1918. C
  1919.       ITER=50
  1920.       TOL=TEN**(-MAX(1,IDIGIT))
  1921. 10    ITER=ITER-1
  1922.       IF(ITER.LT.0) THEN
  1923.         IFAIL=1
  1924.         ERRVAL=ABS(EPS)
  1925.         RETURN
  1926.       END IF
  1927.       CALL LFACT(T,DELTA,N,XNODE,RECUR,R,DR)
  1928.       EPS=-R/DR
  1929.       XNODE=XNODE+EPS
  1930.       IF(ABS(XNODE)+TOL*ABS(EPS).NE.ABS(XNODE)) GOTO 10
  1931. C Final iteration
  1932.       CALL LFACT(T,DELTA,N,XNODE,RECUR,R,DR)
  1933.       EPS=-R/DR
  1934.       XNODE=XNODE+EPS
  1935.       IFAIL=0
  1936.       ERRVAL=ABS(EPS)
  1937. 40    RETURN
  1938.       END
  1939.       SUBROUTINE LFACT(GAMMA,DELTA,N,XNODE,RECUR,R,DR)
  1940.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  1941.       DOUBLE PRECISION GAMMA(0:*),DELTA(0:*),XNODE,R,DR
  1942.       INTEGER N
  1943.       EXTERNAL RECUR
  1944. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1945. C FORTRAN-77 Version 2.2: March 1987
  1946. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1947. C Purpose:
  1948. C
  1949. C Remove the linear factor (X-XNODE) from the polynomial expansion
  1950. C             SUM(I=0 to N) GAMMA(I) P(I,X)
  1951. C to give the quotient,
  1952. C             SUM (I=0 to N-1) DELTA(I)*P(I,X).
  1953. C and the remainder and its derivative at XNODE.
  1954. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1955. C Input parameters:
  1956. C GAMMA  = Polynomial from which factor is to be removed
  1957. C          and expressed as:
  1958. C             GAMMA =   SUM (I=0 to N) GAMMA(I)*P(I,X)
  1959. C          This array should be declared to have at least N+1 elements
  1960. C          in the calling program.
  1961. C N      = Degree of GAMMA.
  1962. C XNODE  = Node to be removed.
  1963. C RECUR  = Name of the subroutine which defines the orthogonal
  1964. C          polynomials. See EXTEND for a full description.
  1965. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1966. C Output parameters:
  1967. C DELTA  = Quotient polynomial expressed as:
  1968. C                  DELTA =   SUM (I=0 to N-1) DELTA(I)*P(I,X)
  1969. C          This array should be declared to have at least N elements
  1970. C          in the calling program.
  1971. C R      = Remainder from division.
  1972. C DR     = Derivative of R with respect to XNODE.
  1973. C          (-R/DR is the Newton correction).
  1974. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  1975.       PARAMETER (ZERO=0.0D0)
  1976. C
  1977.       BK1=ZERO
  1978.       BK2=ZERO
  1979.       DBK1=ZERO
  1980.       DBK2=ZERO
  1981.       CALL RECUR(N,CK,DK,EK)
  1982.       CALL RECUR(N+1,CK1,DK1,EK1)
  1983.       DO 10 K=N,0,-1
  1984.         R=GAMMA(K)+(DK+XNODE*CK)*BK1+EK1*BK2
  1985.         DR=(DK+XNODE*CK)*DBK1+EK1*DBK2+CK*BK1
  1986.         BK2=BK1
  1987.         BK1=R
  1988.         DBK2=DBK1
  1989.         DBK1=DR
  1990.         IF(K.NE.0) THEN
  1991.           CALL RECUR(K-1,CKM1,DKM1,EKM1)
  1992.           DELTA(K-1)=R*CKM1
  1993.         END IF
  1994.         EK1=EK
  1995.         CK=CKM1
  1996.         DK=DKM1
  1997.         EK=EKM1
  1998. 10      CONTINUE
  1999.       RETURN
  2000.       END
  2001.       SUBROUTINE EPROD(N,J,COEFF,WORK,LW,RECUR,IFAIL)
  2002.       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  2003.       DOUBLE PRECISION COEFF(*),WORK(LW,2)
  2004.       INTEGER N,J,LW,IFAIL
  2005.       EXTERNAL RECUR
  2006. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2007. C FORTRAN-77 Version 2.2: March 1987
  2008. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2009. C Purpose:
  2010. C
  2011. C Calculates the expansion of a product of two orthogonal polynomials
  2012. C
  2013. C     P(N,X)*P(J,X) = SUM (I=N-J to N+J ) COEFF(I)*P(I,X)
  2014. C
  2015. C where J must not exceed N. The orthogonal polynomials are defined
  2016. C by the recurrence relation calculated by the external
  2017. C subroutine RECUR.
  2018. C
  2019. C For proper initialisation the subroutine must first be called
  2020. C with J=0 and the required value of N. Subsequent calls must be in
  2021. C the order J=1,2,,,,,N with the appropriate expansion being
  2022. C generated from previous values and returned in COEFF(*). The
  2023. C coefficients of P(N-J,X),...., P(N+J,X) are stored in the array
  2024. C COEFF(1),...,COEFF(2*J+1).
  2025. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2026. C Unless indicated otherwise the type of each variable is implied
  2027. C by the default FORTRAN-77 naming convention.
  2028. C
  2029. C Input parameters:
  2030. C
  2031. C N     = Highest polynomial degree. Note that after the initial
  2032. C         call with J=0 the value of N in this argument is ignored.
  2033. C J     = Current product of P(J,X) with P(N,X) to be calculated.
  2034. C         Note that the subroutine must be first called with J=0 and
  2035. C         the required largest N. Subsequent calls must be
  2036. C         in the order J=1,2,..,N.
  2037. C WORK  = Matrix work area which must be declared in the calling
  2038. C         program to have dimensions at least (2*J+1) by 2.
  2039. C         The contents of this work area must not be altered between
  2040. C         calls by the calling program.
  2041. C LW    = Leading dimension of WORK in the calling program
  2042. C RECUR = Name of the subroutine which defines the orthogonal
  2043. C         polynomials. See EXTEND for a full description.
  2044. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2045. C Output parameters:
  2046. C
  2047. C    COEFF = Array holding the calculated coefficients.
  2048. C            This array should be declared to have at least 2*J+1 elemen
  2049. C            in the calling program.
  2050. C    IFAIL = 0 Result OK
  2051. C          = 1 J exceeds N
  2052. C          = 2 J has not been called sequentially
  2053. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2054.       INTEGER S,SS,IX(2)
  2055.       SAVE IX,SS,LAST
  2056.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  2057. C
  2058.       IFAIL=0
  2059. C Initialise
  2060.       IF(J.EQ.0) THEN
  2061.         IX(1)=1
  2062.         IX(2)=2
  2063.         COEFF(1)=ONE
  2064.         WORK(1,2)=ONE
  2065.         LAST=0
  2066.         SS=N
  2067.         RETURN
  2068.       END IF
  2069.       S=SS
  2070. C Check that J does not exceed S value
  2071.       IF(S.LT.J) THEN
  2072.         IFAIL=1
  2073.         RETURN
  2074.       END IF
  2075. C Check that J is used sequentially
  2076.       IF(LAST.NE.J-1) THEN
  2077.         IFAIL=2
  2078.         RETURN
  2079.       END IF
  2080.       LAST=J
  2081.       J2=J+J
  2082.       CALL RECUR(J-1,CJ1,DJ1,EJ1)
  2083.       IF(J.EQ.1) THEN
  2084.         DO 20 I=1,J2+1
  2085.           COEFF(I)=ZERO
  2086. 20        CONTINUE
  2087.       ELSE
  2088.         DO 25 I=1,J2-3
  2089.           COEFF(I+2)=WORK(I,IX(1))*EJ1
  2090. 25        CONTINUE
  2091.         COEFF(1)   =ZERO
  2092.         COEFF(2)   =ZERO
  2093.         COEFF(J2)  =ZERO
  2094.         COEFF(J2+1)=ZERO
  2095.       END IF
  2096.       IBOT=S-J+1
  2097.       ITOP=S+J-1
  2098.       DO 30 II=IBOT,ITOP
  2099.         I=II-IBOT+1
  2100.         CALL RECUR(II,CI,DI,EI)
  2101.         COEFF(I+2)=COEFF(I+2)+(WORK(I,IX(2))/CI)*CJ1
  2102.         COEFF(I+1)=COEFF(I+1)+WORK(I,IX(2))*(DJ1-(CJ1/CI)*DI)
  2103.         COEFF(I)=COEFF(I)-(WORK(I,IX(2))/CI)*CJ1*EI
  2104. 30      CONTINUE
  2105.       II=IX(1)
  2106.       IX(1)=IX(2)
  2107.       IX(2)=II
  2108.       DO 35 I=1,J2+1
  2109.         WORK(I,IX(2))=COEFF(I)
  2110. 35      CONTINUE
  2111.       RETURN
  2112.       END
  2113.       SUBROUTINE GEFA77(A,LDA,N,IPVT,INFO)
  2114.       INTEGER LDA,N,IPVT(*),INFO
  2115.       DOUBLE PRECISION A(LDA,*)
  2116. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2117. C This is an FORTRAN-77 adaption of LINPACK routine DGEFA
  2118. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2119. C     GEFA77 FACTORS A MATRIX BY GAUSSIAN ELIMINATION.
  2120. C
  2121. C     ON ENTRY
  2122. C
  2123. C        A       THE MATRIX TO BE FACTORED.
  2124. C
  2125. C        LDA     INTEGER
  2126. C                THE LEADING DIMENSION OF THE ARRAY  A .
  2127. C
  2128. C        N       INTEGER
  2129. C                THE ORDER OF THE MATRIX  A .
  2130. C
  2131. C     ON RETURN
  2132. C
  2133. C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
  2134. C                WHICH WERE USED TO OBTAIN IT.
  2135. C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
  2136. C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
  2137. C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
  2138. C
  2139. C        IPVT    INTEGER(N)
  2140. C                AN INTEGER VECTOR OF PIVOT INDICES.
  2141. C
  2142. C        INFO    INTEGER
  2143. C                = 0  NORMAL VALUE.
  2144. C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
  2145. C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
  2146. C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
  2147. C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
  2148. C                     INDICATION OF SINGULARITY.
  2149. C
  2150. C     SUBROUTINES AND FUNCTIONS
  2151. C
  2152. C     BLAS subroutines: DAXPY,DSCAL,IDAMAX
  2153. C     These have been renamed DAXPY7,DSCAL7,IDAMX7
  2154. C
  2155. C     INTERNAL VARIABLES
  2156. C
  2157.       DOUBLE PRECISION T
  2158.       DOUBLE PRECISION ZERO,ONE
  2159.       INTEGER IDAMX7,J,K,KP1,L,NM1
  2160.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  2161. C
  2162. C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
  2163. C
  2164.       INFO = 0
  2165.       NM1 = N - 1
  2166.       IF (NM1 .LT. 1) GO TO 70
  2167.       DO 60 K = 1, NM1
  2168.          KP1 = K + 1
  2169. C
  2170. C        FIND L = PIVOT INDEX
  2171. C
  2172.          L = IDAMX7(N-K+1,A(K,K),1) + K - 1
  2173.          IPVT(K) = L
  2174. C
  2175. C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
  2176.          IF (A(L,K) .EQ. ZERO) GO TO 40
  2177. C
  2178. C           INTERCHANGE IF NECESSARY
  2179. C
  2180.             IF (L .EQ. K) GO TO 10
  2181.                T = A(L,K)
  2182.                A(L,K) = A(K,K)
  2183.                A(K,K) = T
  2184.    10       CONTINUE
  2185. C
  2186. C           COMPUTE MULTIPLIERS
  2187. C
  2188.             T = -ONE/A(K,K)
  2189.             CALL DSCAL7(N-K,T,A(K+1,K),1)
  2190. C
  2191. C           ROW ELIMINATION WITH COLUMN INDEXING
  2192. C
  2193.             DO 30 J = KP1, N
  2194.                T = A(L,J)
  2195.                IF (L .EQ. K) GO TO 20
  2196.                   A(L,J) = A(K,J)
  2197.                   A(K,J) = T
  2198.    20          CONTINUE
  2199.                CALL DAXPY7(N-K,T,A(K+1,K),1,A(K+1,J),1)
  2200.    30       CONTINUE
  2201.          GO TO 50
  2202.    40    CONTINUE
  2203.             INFO = K
  2204.    50    CONTINUE
  2205.    60 CONTINUE
  2206.    70 CONTINUE
  2207.       IPVT(N) = N
  2208.       IF (A(N,N) .EQ. ZERO) INFO = N
  2209.       RETURN
  2210.       END
  2211.       SUBROUTINE GESL77(A,LDA,N,IPVT,B,JOB)
  2212.       INTEGER LDA,N,IPVT(*),JOB
  2213.       DOUBLE PRECISION A(LDA,*),B(*)
  2214. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2215. C This is an FORTRAN-77 adaption of LINPACK routine DGESL
  2216. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2217. C     GESL77 SOLVES THE SYSTEM
  2218. C     A * X = B  OR  TRANS(A) * X = B
  2219. C     USING THE FACTORS COMPUTED BY GEFA77.
  2220. C
  2221. C     ON ENTRY
  2222. C
  2223. C        A       THE OUTPUT FROM GEFA77.
  2224. C
  2225. C        LDA     INTEGER
  2226. C                THE LEADING DIMENSION OF THE ARRAY  A .
  2227. C
  2228. C        N       INTEGER
  2229. C                THE ORDER OF THE MATRIX  A .
  2230. C
  2231. C        IPVT    INTEGER(N)
  2232. C                THE PIVOT VECTOR FROM GEFA77.
  2233. C
  2234. C        B       DIMENSION (N)
  2235. C                THE RIGHT HAND SIDE VECTOR.
  2236. C
  2237. C        JOB     INTEGER
  2238. C                = 0         TO SOLVE  A*X = B ,
  2239. C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
  2240. C                            TRANS(A)  IS THE TRANSPOSE.
  2241. C
  2242. C     ON RETURN
  2243. C
  2244. C        B       THE SOLUTION VECTOR  X .
  2245. C
  2246. C     ERROR CONDITION
  2247. C
  2248. C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
  2249. C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
  2250. C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
  2251. C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
  2252. C        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0
  2253. C        OR DGEFA HAS SET INFO .EQ. 0 .
  2254. C
  2255. C     SUBROUTINES AND FUNCTIONS
  2256. C
  2257. C     BLAS subroutines: DAXPY,DDOT
  2258. C     These have been renamed: DAXPY7,DDOT7
  2259. C     INTERNAL VARIABLES
  2260. C
  2261.       INTEGER K,KB,L,NM1
  2262.       DOUBLE PRECISION DDOT7,T
  2263.       DOUBLE PRECISION ZERO,ONE
  2264.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  2265. C
  2266.       NM1 = N - 1
  2267.       IF (JOB .NE. 0) GO TO 50
  2268. C
  2269. C        JOB = 0 , SOLVE  A * X = B
  2270. C        FIRST SOLVE  L*Y = B
  2271. C
  2272.          IF (NM1 .LT. 1) GO TO 30
  2273.          DO 20 K = 1, NM1
  2274.             L = IPVT(K)
  2275.             T = B(L)
  2276.             IF (L .EQ. K) GO TO 10
  2277.                B(L) = B(K)
  2278.                B(K) = T
  2279.    10       CONTINUE
  2280.             CALL DAXPY7(N-K,T,A(K+1,K),1,B(K+1),1)
  2281.    20    CONTINUE
  2282.    30    CONTINUE
  2283. C
  2284. C        NOW SOLVE  U*X = Y
  2285. C
  2286.          DO 40 KB = 1, N
  2287.             K = N + 1 - KB
  2288.             B(K) = B(K)/A(K,K)
  2289.             T = -B(K)
  2290.             CALL DAXPY7(K-1,T,A(1,K),1,B(1),1)
  2291.    40    CONTINUE
  2292.       GO TO 100
  2293.    50 CONTINUE
  2294. C
  2295. C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
  2296. C        FIRST SOLVE  TRANS(U)*Y = B
  2297. C
  2298.          DO 60 K = 1, N
  2299.             T = DDOT7(K-1,A(1,K),1,B(1),1)
  2300.             B(K) = (B(K) - T)/A(K,K)
  2301.    60    CONTINUE
  2302. C
  2303. C        NOW SOLVE TRANS(L)*X = Y
  2304. C
  2305.          IF (NM1 .LT. 1) GO TO 90
  2306.          DO 80 KB = 1, NM1
  2307.             K = N - KB
  2308.             B(K) = B(K) + DDOT7(N-K,A(K+1,K),1,B(K+1),1)
  2309.             L = IPVT(K)
  2310.             IF (L .EQ. K) GO TO 70
  2311.                T = B(L)
  2312.                B(L) = B(K)
  2313.                B(K) = T
  2314.    70       CONTINUE
  2315.    80    CONTINUE
  2316.    90    CONTINUE
  2317.   100 CONTINUE
  2318.       RETURN
  2319.       END
  2320.       SUBROUTINE  DSCAL7(N,DA,DX,INCX)
  2321. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2322. C This is an FORTRAN-77 adaption of BLAS routine DSCAL
  2323. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2324. C     SCALES A VECTOR BY A CONSTANT.
  2325. C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
  2326. C
  2327.       DOUBLE PRECISION DA,DX(*)
  2328.       DOUBLE PRECISION ZERO,ONE
  2329.       INTEGER I,INCX,M,MP1,N,NINCX
  2330.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  2331. C
  2332.       IF(N.LE.0)RETURN
  2333.       IF(INCX.EQ.1)GO TO 20
  2334. C
  2335. C        CODE FOR INCREMENT NOT EQUAL TO 1
  2336. C
  2337.       NINCX = N*INCX
  2338.       DO 10 I = 1,NINCX,INCX
  2339.         DX(I) = DA*DX(I)
  2340.    10 CONTINUE
  2341.       RETURN
  2342. C
  2343. C        CODE FOR INCREMENT EQUAL TO 1
  2344. C
  2345. C
  2346. C        CLEAN-UP LOOP
  2347. C
  2348.    20 M = MOD(N,5)
  2349.       IF( M .EQ. 0 ) GO TO 40
  2350.       DO 30 I = 1,M
  2351.         DX(I) = DA*DX(I)
  2352.    30 CONTINUE
  2353.       IF( N .LT. 5 ) RETURN
  2354.    40 MP1 = M + 1
  2355.       DO 50 I = MP1,N,5
  2356.         DX(I) = DA*DX(I)
  2357.         DX(I + 1) = DA*DX(I + 1)
  2358.         DX(I + 2) = DA*DX(I + 2)
  2359.         DX(I + 3) = DA*DX(I + 3)
  2360.         DX(I + 4) = DA*DX(I + 4)
  2361.    50 CONTINUE
  2362.       RETURN
  2363.       END
  2364.       INTEGER FUNCTION IDAMX7(N,DX,INCX)
  2365. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2366. C This is an FORTRAN-77 adaption of BLAS routine IDAMAX
  2367. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2368. C
  2369. C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
  2370. C
  2371.       DOUBLE PRECISION DX(*),DMAX
  2372.       INTEGER I,INCX,IX,N
  2373. C
  2374.       IDAMX7 = 0
  2375.       IF( N .LT. 1 ) RETURN
  2376.       IDAMX7 = 1
  2377.       IF(N.EQ.1)RETURN
  2378.       IF(INCX.EQ.1)GO TO 20
  2379. C
  2380. C        CODE FOR INCREMENT NOT EQUAL TO 1
  2381. C
  2382.       IX = 1
  2383.       DMAX = ABS(DX(1))
  2384.       IX = IX + INCX
  2385.       DO 10 I = 2,N
  2386.          IF(ABS(DX(IX)).LE.DMAX) GO TO 5
  2387.          IDAMX7 = I
  2388.          DMAX = ABS(DX(IX))
  2389.     5    IX = IX + INCX
  2390.    10 CONTINUE
  2391.       RETURN
  2392. C
  2393. C        CODE FOR INCREMENT EQUAL TO 1
  2394. C
  2395.    20 DMAX = ABS(DX(1))
  2396.       DO 30 I = 2,N
  2397.          IF(ABS(DX(I)).LE.DMAX) GO TO 30
  2398.          IDAMX7 = I
  2399.          DMAX = ABS(DX(I))
  2400.    30 CONTINUE
  2401.       RETURN
  2402.       END
  2403.       SUBROUTINE DAXPY7(N,DA,DX,INCX,DY,INCY)
  2404. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2405. C This is an FORTRAN-77 adaption of BLAS routine DAXPY
  2406. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2407. C
  2408. C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
  2409. C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
  2410. C
  2411.       DOUBLE PRECISION DX(*),DY(*),DA
  2412.       INTEGER I,INCX,INCY,IXIY,M,MP1,N
  2413.       DOUBLE PRECISION ZERO,ONE
  2414.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  2415. C
  2416.       IF(N.LE.0)RETURN
  2417.       IF (DA .EQ. ZERO) RETURN
  2418.       IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
  2419. C
  2420. C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
  2421. C          NOT EQUAL TO 1
  2422. C
  2423.       IX = 1
  2424.       IY = 1
  2425.       IF(INCX.LT.0)IX = (-N+1)*INCX + 1
  2426.       IF(INCY.LT.0)IY = (-N+1)*INCY + 1
  2427.       DO 10 I = 1,N
  2428.         DY(IY) = DY(IY) + DA*DX(IX)
  2429.         IX = IX + INCX
  2430.         IY = IY + INCY
  2431.    10 CONTINUE
  2432.       RETURN
  2433. C
  2434. C        CODE FOR BOTH INCREMENTS EQUAL TO 1
  2435. C
  2436. C        CLEAN-UP LOOP
  2437. C
  2438.    20 M = MOD(N,4)
  2439.       IF( M .EQ. 0 ) GO TO 40
  2440.       DO 30 I = 1,M
  2441.         DY(I) = DY(I) + DA*DX(I)
  2442.    30 CONTINUE
  2443.       IF( N .LT. 4 ) RETURN
  2444.    40 MP1 = M + 1
  2445.       DO 50 I = MP1,N,4
  2446.         DY(I) = DY(I) + DA*DX(I)
  2447.         DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
  2448.         DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
  2449.         DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
  2450.    50 CONTINUE
  2451.       RETURN
  2452.       END
  2453.       DOUBLE PRECISION FUNCTION DDOT7(N,DX,INCX,DY,INCY)
  2454. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2455. C This is an FORTRAN-77 adaption of BLAS routine DDOT
  2456. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  2457. C
  2458. C     FORMS THE DOT PRODUCT OF TWO VECTORS.
  2459. C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
  2460. C
  2461.       DOUBLE PRECISION DX(*),DY(*),DTEMP
  2462.       INTEGER I,INCX,INCY,IX,IY,M,MP1,N
  2463.       DOUBLE PRECISION ZERO,ONE
  2464.       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  2465. C
  2466.       DDOT7 = ZERO
  2467.       DTEMP = ZERO
  2468.       IF(N.LE.0)RETURN
  2469.       IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
  2470. C
  2471. C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
  2472. C          NOT EQUAL TO 1
  2473. C
  2474.       IX = 1
  2475.       IY = 1
  2476.       IF(INCX.LT.0)IX = (-N+1)*INCX + 1
  2477.       IF(INCY.LT.0)IY = (-N+1)*INCY + 1
  2478.       DO 10 I = 1,N
  2479.         DTEMP = DTEMP + DX(IX)*DY(IY)
  2480.         IX = IX + INCX
  2481.         IY = IY + INCY
  2482.    10 CONTINUE
  2483.       DDOT7 = DTEMP
  2484.       RETURN
  2485. C
  2486. C        CODE FOR BOTH INCREMENTS EQUAL TO 1
  2487. C
  2488. C
  2489. C        CLEAN-UP LOOP
  2490. C
  2491.    20 M = MOD(N,5)
  2492.       IF( M .EQ. 0 ) GO TO 40
  2493.       DO 30 I = 1,M
  2494.         DTEMP = DTEMP + DX(I)*DY(I)
  2495.    30 CONTINUE
  2496.       IF( N .LT. 5 ) GO TO 60
  2497.    40 MP1 = M + 1
  2498.       DO 50 I = MP1,N,5
  2499.         DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
  2500.      *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
  2501.    50 CONTINUE
  2502.    60 DDOT7 = DTEMP
  2503.       RETURN
  2504.       END
  2505. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2506. C                      Demonstration driver
  2507. C      (Quadruple precision version of package for VAX/VMS)
  2508. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2509. C The following templates demonstrate the use of the procedure EXTEND
  2510. C to generate sequences of extended quadrature rules for various weight
  2511. C functions given the definitions of the orthogonal polynomial 3-term
  2512. C recurrence relations. ICASE selects the
  2513. C required sequence as follows:
  2514. C    ICASE = 1    3-point Gauss-Legendre in [-1,1]
  2515. C    ICASE = 2    2-point Gauss-Lobatto in [-1,1]
  2516. C    ICASE = 3    6-point Radau in [-1,1]
  2517. C    ICASE = 4    2-point Gauss-Laguerre in [0,infinity)
  2518. C    ICASE = 5    3-point Gauss-Hermite in (-infinity,infinity)
  2519. C    ICASE = 6    3-point Gauss-Jacobi in [0,1]
  2520. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2521. C FORTRAN-77 code
  2522. C Unless indicated otherwise the type of each variable is implied
  2523. C by the default FORTRAN-77 naming convention.
  2524. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2525.       IMPLICIT REAL*16 (A-H,O-Z)
  2526.       PARAMETER (LDA=257,LDB=2*LDA+1,IDIGIT=8,NEXP=4931,NTEST=4)
  2527.       PARAMETER (ONE=1.0Q0,TWO=2.0Q0,THREE=3.0Q0)
  2528.       REAL*16 T(0:LDA),EXT(0:LDA)
  2529.       REAL*16 QR(LDA),QI(LDA)
  2530.       REAL*16 PNODES(LDA),WT(LDA)
  2531.       REAL*16 ERR(LDA),TEST(0:NTEST)
  2532.       REAL*16 WORKA(LDA,LDA),WORKB(LDB,3)
  2533.       INTEGER IWORK(LDA)
  2534.       LOGICAL SYMMET,START
  2535.       EXTERNAL RECURA,RECURB,RECURC,RECURD
  2536. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2537. C Get data from terminal
  2538. C
  2539. C Select demonstration
  2540. 5     WRITE(*,10)
  2541. 10    FORMAT(' Case ?:')
  2542.       READ(*,*)ICASE
  2543.       ICASE=MAX(1,ICASE)
  2544. C Select number of iterative extensions to be performed
  2545.       WRITE(*,20)
  2546. 20    FORMAT(' No. of rules?:')
  2547.       READ(*,*)NSEQ
  2548.       NSEQ=MAX(1,NSEQ)
  2549.       I=1
  2550. 50    GOTO(100,200,300,400,500,600),ICASE
  2551. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2552. C Demonstration 1 - extension of 3-point Gauss-Legendre rule
  2553. C Recurrence defined by RECURA
  2554. 100   IF(I.EQ.1) THEN
  2555. C Generate 3-point Gauss initially from zero point rule,
  2556. C i.e. no pre-assigned nodes, symmetry exploited.
  2557.         WRITE(*,*) 'Gauss-Legendre 3-point extension'
  2558.         N=0
  2559.         M=3
  2560.         M0=0
  2561.         T(0)=ONE
  2562.         SYMMET=.TRUE.
  2563.         START=.FALSE.
  2564.       ELSE
  2565. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  2566. C generated in the previous cycle
  2567.         M=N+1
  2568.         START=.FALSE.
  2569.       END IF
  2570. C Calculate extension
  2571.       H0=TWO
  2572.       IDEG=N+2*M-1
  2573.       CALL EXTEND(N,M,M0,T,RECURA,SYMMET,START,PNODES,H0,NEXP,
  2574.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  2575.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  2576. C Tests
  2577.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  2578.         DO 120 K=0,MIN(NTEST,IDEG/2)
  2579.           CALL CHECK(N,PNODES,WT,K,H0,RECURA,TEST(K),IERR)
  2580. 120       CONTINUE
  2581.       END IF
  2582.       GOTO 2000
  2583. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2584. C Demonstration 2 - extension of 2-point Lobatto rule
  2585. C Recurrence defined by RECURA
  2586. 200   IF(I.EQ.1) THEN
  2587. C Add one node, Pre-assign -1.0 and 1.0, symmetry exploited.
  2588.         WRITE(*,*) 'Lobatto 2-point extension'
  2589.         N=2
  2590.         M=1
  2591.         PNODES(1)=ONE
  2592.         PNODES(2)=-ONE
  2593.         SYMMET=.TRUE.
  2594.         START=.TRUE.
  2595.       ELSE
  2596. C Add N-1 nodes using the pre-assigned nodes defined by the T polynomial
  2597. C generated in the previous cycle
  2598.         M=N-1
  2599.         START=.FALSE.
  2600.       END IF
  2601.       H0=TWO
  2602.       IDEG=N+2*M-1
  2603.       CALL EXTEND(N,M,M0,T,RECURA,SYMMET,START,PNODES,H0,NEXP,
  2604.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  2605.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  2606. C Tests
  2607.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  2608.         DO 220 K=0,MIN(NTEST,IDEG/2)
  2609.           CALL CHECK(N,PNODES,WT,K,H0,RECURA,TEST(K),IERR)
  2610. 220       CONTINUE
  2611.       END IF
  2612.       GOTO 2000
  2613. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2614. C Demonstration 3 - extension of 6-point Radau rule
  2615. C Recurrence defined by RECURA
  2616. 300   IF(I.EQ.1) THEN
  2617. C Add five nodes. Pre-assign -1.0, no symmetry.
  2618.         WRITE(*,*) 'Radau 6-point extension'
  2619.         N=1
  2620.         M=5
  2621.         PNODES(1)=-ONE
  2622.         SYMMET=.FALSE.
  2623.         START=.TRUE.
  2624.       ELSE
  2625. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  2626. C generated in the previous cycle
  2627.         M=N+1
  2628.         START=.FALSE.
  2629.       END IF
  2630.       H0=TWO
  2631.       IDEG=N+2*M-1
  2632.       CALL EXTEND(N,M,M0,T,RECURA,SYMMET,START,PNODES,H0,NEXP,
  2633.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  2634.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  2635. C Tests
  2636.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  2637.         DO 320 K=0,MIN(NTEST,IDEG/2)
  2638.           CALL CHECK(N,PNODES,WT,K,H0,RECURA,TEST(K),IERR)
  2639. 320       CONTINUE
  2640.       END IF
  2641.       GOTO 2000
  2642. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2643. C Demonstration 4 - extension of 2-point Gauss-Laguerre
  2644. C Recurrence defined by RECURB
  2645. 400   IF(I.EQ.1) THEN
  2646. C Generate 2-point rule initially from zero point rule,
  2647. C i.e. no pre-assigned nodes, no symmetry.
  2648.         WRITE(*,*) 'Gauss-Laguerre 2-point extension'
  2649.         N=0
  2650.         M=2
  2651.         M0=0
  2652.         T(0)=ONE
  2653.         SYMMET=.FALSE.
  2654.         START=.FALSE.
  2655.       ELSE
  2656. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  2657. C generated in the previous cycle
  2658.         M=N+1
  2659.         START=.FALSE.
  2660.       END IF
  2661. C Calculate extension
  2662.       H0=ONE
  2663.       IDEG=N+2*M-1
  2664.       CALL EXTEND(N,M,M0,T,RECURB,SYMMET,START,PNODES,H0,NEXP,
  2665.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  2666.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  2667. C Tests
  2668.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  2669.         DO 420 K=0,MIN(NTEST,IDEG/2)
  2670.           CALL CHECK(N,PNODES,WT,K,H0,RECURB,TEST(K),IERR)
  2671. 420       CONTINUE
  2672.       END IF
  2673.       GOTO 2000
  2674. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2675. C Demonstration 5 - extension of 3-point Gauss-Hermite rule
  2676. C Recurrence defined by RECURC
  2677. 500   IF(I.EQ.1) THEN
  2678. C Generate 3-point rule initially from zero point rule,
  2679. C i.e. no pre-assigned nodes, symmetry exploited.
  2680.         WRITE(*,*) 'Gauss-Hermite 3-point extension'
  2681.         M=3
  2682.         N=0
  2683.         M0=0
  2684.         T(0)=ONE
  2685.         SYMMET=.TRUE.
  2686.         START=.FALSE.
  2687.       ELSE
  2688. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  2689. C generated in the previous cycle
  2690.         M=N+1
  2691.         START=.FALSE.
  2692.       END IF
  2693. C Calculate extension
  2694. C Zero moment integral = sqrt(pi)
  2695.       H0=TWO*SQRT(ATAN(ONE))
  2696.       IDEG=N+2*M-1
  2697.       CALL EXTEND(N,M,M0,T,RECURC,SYMMET,START,PNODES,H0,NEXP,
  2698.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  2699.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  2700. C Tests
  2701.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  2702.         DO 520 K=0,MIN(NTEST,IDEG/2)
  2703.           CALL CHECK(N,PNODES,WT,K,H0,RECURC,TEST(K),IERR)
  2704. 520       CONTINUE
  2705.       END IF
  2706.       GOTO 2000
  2707. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2708. C Demonstration 6 - extension of 3-point Gauss-Jacobi
  2709. C for weight sqrt(x) in [0,1]
  2710. C Recurrence defined by RECURD
  2711. 600   IF(I.EQ.1) THEN
  2712. C Generate 3-point rule initially from zero point rule,
  2713. C i.e. no pre-assigned nodes, no symmetry.
  2714.         WRITE(*,*) 'Gauss-Jacobi 3-point extension'
  2715.         M=3
  2716.         N=0
  2717.         M0=0
  2718.         T(0)=ONE
  2719.         SYMMET=.FALSE.
  2720.         START=.FALSE.
  2721.       ELSE
  2722. C Add N+1 nodes using the pre-assigned nodes defined by the T polynomial
  2723. C generated in the previous cycle
  2724.         M=N+1
  2725.         START=.FALSE.
  2726.       END IF
  2727. C Calculate extension
  2728.       H0=TWO/THREE
  2729.       IDEG=N+2*M-1
  2730.       CALL EXTEND(N,M,M0,T,RECURD,SYMMET,START,PNODES,H0,NEXP,
  2731.      *            IDIGIT,WT,NODES,QR,QI,ERR,EXT,
  2732.      *            IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  2733. C Tests
  2734.       IF(IFLAG.EQ.0.OR.IFLAG.EQ.6) THEN
  2735.         DO 620 K=0,MIN(NTEST,IDEG/2)
  2736.           CALL CHECK(N,PNODES,WT,K,H0,RECURD,TEST(K),IERR)
  2737. 620       CONTINUE
  2738.       END IF
  2739.       GOTO 2000
  2740. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2741. C Display results
  2742. 2000  WRITE(*,*)'Iteration',I
  2743.       WRITE(*,*)'Coefficients of expansion whose roots ',
  2744.      *          'are the new nodes:'
  2745.       WRITE(*,3000)(EXT(J),J,J=0,M)
  2746. C
  2747.       WRITE(*,*)'New nodes'
  2748.       WRITE(*,3100)(QR(K),QI(K),IWORK(K),ERR(K),K=1,NODES)
  2749. C
  2750.       WRITE(*,*)'New full extended expansion'
  2751.       WRITE(*,3010)(T(J-M0),J,J=M0,N)
  2752. C
  2753.       WRITE(*,3200)I,N,IFLAG,NODES
  2754.       IF(IFLAG.NE.0.AND.IFLAG.NE.6) THEN
  2755.         WRITE(*,*)'Terminated prematurely - see IFLAG'
  2756.         GOTO 5
  2757.       END IF
  2758. C Print rule (positive nodes only if symmetry present)
  2759.       IF(SYMMET) THEN
  2760.         NUM=(N+1)/2
  2761.       ELSE
  2762.         NUM=N
  2763.       END IF
  2764.       WRITE(*,3300)(J,PNODES(J),WT(J),J=1,NUM)
  2765. C Display test results
  2766.       DO 2010 K=0,MIN(NTEST,IDEG/2)
  2767.         WRITE(*,3400)K,TEST(K)
  2768. 2010    CONTINUE
  2769.       IF(IFLAG.EQ.6) THEN
  2770.         WRITE(*,*)'Rule test is unsatisfactory'
  2771.         GOTO 5
  2772.       END IF
  2773.       I=I+1
  2774.       IF(I.LE.NSEQ) GOTO 50
  2775.       GOTO 5
  2776. C
  2777. 3000  FORMAT(D25.16,'*P(',I3,',X)')
  2778. 3010  FORMAT(D25.16,'*P(',I3,',X)/HI')
  2779. 3100  FORMAT(21X,'REAL',16X,'IMAGINARY',1X,'FLAG',7X,'ERR'/,
  2780.      *                                         (2D25.16,I5,D10.1))
  2781. 3200  FORMAT(' Complete extended rule: STEP=',I2,'  POINTS=',I3,
  2782.      *       '  IFLAG=',I1,'  NODES ADDED=',I3)
  2783. 3300  FORMAT(2X,'No.',21X,'NODE',19X,'WEIGHT',/,(I5,2D25.16))
  2784. 3400  FORMAT(' TEST(',I2,')=',D25.16)
  2785.       END
  2786. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2787. C User defined subroutines - Recurrence relations
  2788. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2789.       SUBROUTINE RECURA(K,C,D,E)
  2790.       IMPLICIT REAL*16 (A-H,O-Z)
  2791.       INTEGER K
  2792. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2793. C Purpose:
  2794. C
  2795. C This is an example of a user supplied subroutine to define the
  2796. C orthogonal polynomials.
  2797. C
  2798. C CALL RECUR(K,C,D,E) gives the coefficients C,D and E such that,
  2799. C
  2800. C            P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  2801. C
  2802. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2803. C Unless indicated otherwise the type of each variable is implied
  2804. C by the default FORTRAN-77 naming convention.
  2805. C
  2806. C Input parameter:
  2807. C K       = Index for relation
  2808. C Output parameters:
  2809. C C,D,E   = Parameters in the recurrence relation
  2810. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2811.       PARAMETER (ZERO=0.0Q0)
  2812. C Legendre recurrence for [-1,1]
  2813. C Covers Gauss, Lobatto and Radau
  2814.       F=FLOAT(K+1)
  2815.       C=FLOAT(2*K+1)/F
  2816.       D=ZERO
  2817.       E=-FLOAT(K)/F
  2818.       RETURN
  2819.       END
  2820.       SUBROUTINE RECURB(K,C,D,E)
  2821.       IMPLICIT REAL*16 (A-H,O-Z)
  2822.       INTEGER K
  2823. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2824. C Purpose: See RECURA
  2825. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2826.       PARAMETER (ONE=1.0Q0)
  2827. C Laguerre recurrence
  2828.       F=FLOAT(K+1)
  2829.       C=-ONE/F
  2830.       D=FLOAT(2*K+1)/F
  2831.       E=-FLOAT(K)/F
  2832.       RETURN
  2833.       END
  2834.       SUBROUTINE RECURC(K,C,D,E)
  2835.       IMPLICIT REAL*16 (A-H,O-Z)
  2836.       INTEGER K
  2837. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2838. C Purpose: See RECURA
  2839. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2840.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0,TWO=2.0Q0)
  2841. C Hermite recurrence
  2842.       C=ONE
  2843.       D=ZERO
  2844.       E=-FLOAT(K)/TWO
  2845.       RETURN
  2846.       END
  2847.       SUBROUTINE RECURD(K,C,D,E)
  2848.       IMPLICIT REAL*16 (A-H,O-Z)
  2849.       INTEGER K
  2850. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2851. C Purpose: See RECURA
  2852. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2853.       PARAMETER (ONE=1.0Q0,TWO=2.0Q0,ONEP5=1.5Q0)
  2854. C Jacobi polynomials in [0,1]
  2855. C Weight function is (1-x)**(p-q)*x**(q-1)
  2856. C
  2857. C Case for weight sqrt(x)   i.e. p=3/2 and q=p
  2858.       P=ONEP5
  2859.       Q=P
  2860.       FK=FLOAT(K)
  2861.       F2K=FK*TWO
  2862.       B=F2K+P
  2863.       BP1=B+ONE
  2864.       X3=(B-TWO)*(B-ONE)*B
  2865.       A1=(B-ONE)*BP1*X3
  2866.       A2=-X3*(F2K*(FK+P)+Q*(P-ONE))
  2867.       A3=X3*BP1*(B-ONE)
  2868.       A4=FK*(FK+Q-ONE)*(FK+P-ONE)*(FK+P-Q)*BP1
  2869.       C=A3/A1
  2870.       D=A2/A1
  2871.       E=-A4/A1
  2872.       RETURN
  2873.       END
  2874. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2875. C        Main algorithm begins here with structure:
  2876. C                     ->   ASSIGN
  2877. C
  2878. C                     ->   GENER  ----> EPROD
  2879. C
  2880. C       EXTEND -------->   SOLVE  ----> NEWTON/BAIR
  2881. C         v
  2882. C         v           ->   RSORT
  2883. C         v
  2884. C       CHECK         ->   WEIGHT
  2885. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2886.       SUBROUTINE EXTEND(N,M,M0,T,RECUR,SYMMET,START,PNODES,H0,NEXP,
  2887.      *                  IDIGIT,WT,NODES,QRNODE,QINODE,ERR,EXT,
  2888.      *                  IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  2889.       IMPLICIT REAL*16 (A-H,O-Z)
  2890.       REAL*16 T(0:*),EXT(0:*)
  2891.       REAL*16 PNODES(*),WT(*),H0
  2892.       REAL*16 QRNODE(*),QINODE(*),ERR(*)
  2893.       REAL*16 WORKA(0:LDA-1,0:*),WORKB(0:LDB-1,*)
  2894.       INTEGER M0,N,M,IWORK(*),LDA,LDB,NODES,IFLAG,NEXP,IDIGIT
  2895.       LOGICAL SYMMET,START
  2896.       EXTERNAL RECUR
  2897. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2898. C FORTRAN-77 Version 2.2: March 1987
  2899. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2900. C Please address queries or comments to:
  2901. C
  2902. C        T.N.L. Patterson
  2903. C        Department of Applied Mathematics & Theoretical Physics
  2904. C        The Queen's University of Belfast
  2905. C        Belfast, BT9 1NN
  2906. C        N. Ireland
  2907. C
  2908. C        Tel: International +44 232 245133 Ext. 3792.
  2909. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2910. C Purpose:
  2911. C
  2912. C Calculates the N+M node quadrature rule composed of N pre-assigned nod
  2913. C together with M nodes chosen optimally to achieve algebraic degree of
  2914. C precision of at least N+2*M-1.
  2915. C
  2916. C The orthogonal system of polynomials associated with the quadrature
  2917. C weight is defined generally by the recurrence relation specified in th
  2918. C user supplied subroutine RECUR.
  2919. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  2920. C Unless indicated otherwise the type of each variable is implied
  2921. C by the default FORTRAN-77 naming convention.
  2922. C
  2923. C Input parameters:
  2924. C N     = Number of pre-assigned nodes (and upper limit to the expansion
  2925. C         Note that if successful this is reset to N+M on completion
  2926. C         (the appropriate value for iterative use).
  2927. C M     = Number of nodes to be optimally added.
  2928. C M0    = Lower limit to the expansion of T. This is ignored if START
  2929. C         is .TRUE. Note that if successful this is reset to M
  2930. C         on completion (the appropriate value for iterative use).
  2931. C T     = Array holding the coefficients TI of the polynomial whose
  2932. C         roots define the N pre-assigned nodes of the quadrature
  2933. C         rule and expressed as:
  2934. C                  SUM (I=M0 to N) (TI/HI)*P(I,X)
  2935. C         where HI is the integral of W(X)*P(I,X)**2 over the
  2936. C         interval for which orthogonality with respect the weight
  2937. C         W(X) is defined (moment integrals) and P(I,X) is the
  2938. C         orthogonal polynomial of degree I. Element T(I-M0) holds the
  2939. C         value of TI.
  2940. C
  2941. C         Note that T is either,
  2942. C            (1) provided explicitly,
  2943. C            (2) generated automatically from the N pre-assigned nodes
  2944. C                given in PNODES(*) (if START is .TRUE.)
  2945. C         or,
  2946. C            (3) generated from a previous call to the subroutine.
  2947. C         This array should be declared to have at least
  2948. C         max(N-M0+1,M+1) elements in the calling program.
  2949. C
  2950. C         The service subroutine TRANSF can be used to transform
  2951. C         the expansion to the required input form if desired
  2952. C         with the parameter IFLAG set to 1.
  2953. C RECUR = Name of user supplied subroutine which defines the orthogonal
  2954. C         polynomials. Given K, CALL RECUR(K,C,D,E) gives
  2955. C         the coefficients C,D and E such that,
  2956. C                     P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  2957. C           The parameters are defined as follows:
  2958. C             K = Index
  2959. C             C,D,E = Parameters in the recurrence relation
  2960. C                                                (functions of K)
  2961. C SYMMET = .FALSE. if no advantage is to be taken of symmetry, if any,
  2962. C          about x=0 in the interval of integration and the
  2963. C          orthogonality  weight function. Note that if symmetry in
  2964. C          fact does exist setting this parameter to zero will still
  2965. C          produce correct results - only efficiency is effected.
  2966. C        = .TRUE. if the extended rule computations should
  2967. C          exploit symmetry about x=0 in the interval of
  2968. C          integration and the orthogonality  weight function.
  2969. C          This reduces the size of the system of linear equations
  2970. C          determining EXT by a factor of about 2 (see WORKA). If
  2971. C          symmetry does not in fact exist erroneous results will be
  2972. C          produced.
  2973. C START  = .TRUE. then the polynomial T is generated to have
  2974. C          the pre-assigned nodes (PNODES) as its roots.
  2975. C        = .FALSE. then the supplied values of the coefficients
  2976. C          of T are used directly (see above).
  2977. C PNODES = Array holding the pre-assigned nodes. This array should
  2978. C          be declared to have at least N+M elements in the calling prog
  2979. C H0     = Integral of the orthogonality weight function over the
  2980. C          interval of integration. Zero moment integral.
  2981. C NEXP   = Largest negative decimal exponent supported on the
  2982. C          computer. (Positive number - typical value 38).
  2983. C          Weights less than approximately 10**(-NEXP) are set to zero
  2984. C          when the Christoffel-Darboux identity is used (N=M).
  2985. C IDIGIT = Node convergence parameter (integer greater than 0).
  2986. C          An attempt is made to calculate the nodes to the maximum
  2987. C          accuracy possible by the machine precision available.
  2988. C          IDIGIT controls the assessment procedure to take account of
  2989. C          round-off errors and specifies the number of least significan
  2990. C          decimal digits that can be ignored (i.e. attributed
  2991. C          to round-off) in the computed relative error. Typical
  2992. C          value is 5.
  2993. C IWORK  = Integer working array which should be declared in the
  2994. C          calling program to have at least max(M,N) elements.
  2995. C          On return IWORK provides information on the convergence
  2996. C          of the nodes. See output parameters.
  2997. C WORKA  = Real working matrix which should be declared in the calling
  2998. C          program to have dimension at least max(M+1,N)
  2999. C          by max(M+1,N+1). If SYMMET=.TRUE. (see above) the
  3000. C          dimension can be reduced to max(M/2+1,N)
  3001. C          by max(M/2+1,N+1).
  3002. C LDA    = Number of elements in the leading dimension of WORKA
  3003. C          declared in the calling program.
  3004. C WORKB  = Real working matrix which should be declared in the calling
  3005. C          program to have dimension at least 2*M+1 by 3.
  3006. C LDB    = Number of elements in the leading dimension of WORKB
  3007. C          declared in the calling program
  3008. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3009. C Output parameters:
  3010. C PNODES = Ordered array holding the N+M nodes of the extended
  3011. C          quadrature rule made up from the original pre-assigned
  3012. C          nodes and the new optimally extended nodes. These values can
  3013. C          be used in subsequent iterative use of the subroutine.
  3014. C WT     = Array holding the values of the quadrature weights for
  3015. C          the extended rule associated with the nodes held in PNODES.
  3016. C          This array should be declared to have at least N+M elements
  3017. C          in the calling program.
  3018. C T      = Array holding the coefficients TI of the new orthogonal
  3019. C          expansion whose roots are the nodes of the extended quadratur
  3020. C          (that is, the pre-assigned nodes plus the extended nodes) and
  3021. C          is expressed as:
  3022. C                      SUM (I=M to N+M) (TI/HI)*P(I,X)
  3023. C          T(I-M) holds the value of TI.
  3024. C          (For definitions see description of input argument T).
  3025. C          This polynomial can be used as input for further extensions.
  3026. C
  3027. C          The service subroutine TRANSF can be used to remove the
  3028. C          moment factors from the expansion if desired with the
  3029. C          parameter IFLAG set to 0.
  3030. C M0     = Lower limit defining the new orthogonal expansion T.
  3031. C          (Set to M).
  3032. C N      = Upper limit defining the new orthogonal expansion T.
  3033. C          (Set to the original value of N+M).
  3034. C NODES  = Number of extended nodes found. Normally equals M but see IFL
  3035. C QRNODE = Array holding the real parts of the extended nodes (1,..,NODE
  3036. C          This array should be declared to have at least M elements
  3037. C          in the calling program.
  3038. C QINODE = Array holding the imaginary parts of the extended
  3039. C          nodes (1,..,NODES). (Hopefully these values are zero!).
  3040. C          This array should be declared to have at least M elements
  3041. C          in the calling program.
  3042. C ERR    = Array holding a measure of the relative error in the
  3043. C          nodes. This may be inspected if the convergence
  3044. C          error flag has been raised (IFLAG=3) to decide if the nodes
  3045. C          in question are acceptable. (ERR(*) actually gives the mean
  3046. C          last correction to the quadratic factor in the generalised
  3047. C          Bairstow root finder (see BAIR). This should declared in
  3048. C          the calling program to have at least M elements.
  3049. C EXT    = Array holding the coefficients of the polynomial whose
  3050. C          roots are the  extended nodes (QRNODES(*),QINODES(*)) and
  3051. C          expressed as:
  3052. C                EXT =   SUM (I=0 to M) EXT(I)*P(I,X)
  3053. C          This array should be declared to have at least M+1 elements
  3054. C          in the calling program.
  3055. C IWORK  = Node convergence flags. Elements 1 to NODES give information
  3056. C          on the convergence of the roots of the polynomial EXT
  3057. C          corresponding to each extended node.
  3058. C          Element I = 0 Convergence of I th root satisfactory
  3059. C          Element I = 1 Convergence of I th root unsatisfactory
  3060. C IFLAG  = 0, No error detected
  3061. C        = 1, The linear system of equations defining the polynomial
  3062. C             whose roots are the extended nodes became singular or
  3063. C             very  ill-conditioned.   (FATAL).
  3064. C        = 2, The linear system of equations used to generate the
  3065. C             polynomial T when START is .TRUE. became singular
  3066. C             or very ill-conditioned. (FATAL).
  3067. C        = 3, Poor convergence has been detected in the calculation
  3068. C             of the roots of EXT (see above) corresponding to the new
  3069. C             nodes or all nodes have not been found (M not equal
  3070. C             to NODES). See also ERR(*) below.
  3071. C        = 4, Possible imaginary nodes detected.
  3072. C        = 5, Value of N and M incompatible for SYMMET=.TRUE.
  3073. C             Both cannot be odd. (FATAL)
  3074. C        = 6, Test of new quadrature rule has failed.
  3075. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3076. C Library routines called: LINPACK - DGEFA, DGESL
  3077. C FORTRAN-77 versions of these are included and renamed GEFA77 and GESL7
  3078. C These call the BLAS routines DSCAL, IDAMAX, DAXPY and DDOT
  3079. C which are renamed DSCAL7, IDAMX7, DAXPY7 and DDOT7.
  3080. C (Quadruple precision versions used for this subprogram)
  3081. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3082. C Changing the precision.
  3083. C
  3084. C This is accomplished as follows:
  3085. C (1) Amend the TYPE statements,
  3086. C (2) Select an appropriate value for the NEXP argument to EXTEND.
  3087. C
  3088. C NOTE:
  3089. C (a) All constants used are specified in PARAMETER statements at the st
  3090. C     of each subprogram and,
  3091. C (b) Generic names are used for all function calls.
  3092. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3093.       INTEGER S
  3094. C
  3095.       IFLAG=0
  3096.       NODES=0
  3097.       IDEG=N+2*M-1
  3098. C Look for incompatible values of N and M
  3099.       IF(SYMMET) THEN
  3100. C         Both N and M cannot be odd
  3101.           IF(MOD(N,2).EQ.1.AND.MOD(M,2).EQ.1) THEN
  3102.             IFLAG=5
  3103.             RETURN
  3104.           END IF
  3105.       END IF
  3106. C Generate if required the initial T polynomial corresponding to
  3107. C prescribed pre-assigned nodes
  3108.       IF(START .AND. N.NE.0) THEN
  3109.         CALL ASSIGN(N,PNODES,IWORK,WORKA,LDA,RECUR,T,IERR)
  3110.         M0=0
  3111.         IF(IERR.NE.0) THEN
  3112.           IFLAG=2
  3113.           RETURN
  3114.         END IF
  3115.       END IF
  3116.       NLAST=N
  3117. C Generate extended expansion coefficients and overwrite T
  3118.       CALL GENER(T,M0,N,M,RECUR,SYMMET,EXT,
  3119.      *                          IWORK,WORKA,LDA,WORKB,LDB,IERR)
  3120.       IF(IERR.NE.0) THEN
  3121.         IFLAG=1
  3122.         RETURN
  3123.       END IF
  3124. C Find extended nodes as roots of EXT(*)
  3125.       CALL SOLVE(EXT,M,SYMMET,RECUR,IDIGIT,QRNODE,QINODE,
  3126.      *                        NODES,ERR,IWORK,WORKB,LDB,IERR)
  3127.       IF(IERR.NE.0) IFLAG=IERR+2
  3128.       IF(IFLAG.NE.0) RETURN
  3129. C Accumulate nodes for extended rule
  3130.       DO 10 I=1,M
  3131.         PNODES(NLAST+I)=QRNODE(I)
  3132. 10      CONTINUE
  3133. C Re-order
  3134.       CALL RSORT(PNODES,N,1)
  3135. C Compute weights (only for positive nodes if symmetric)
  3136.       IF(SYMMET) THEN
  3137.         NUM=(N+1)/2
  3138.       ELSE
  3139.         NUM=N
  3140.       END IF
  3141.       DO 20 I=1,NUM
  3142.         CALL WEIGHT(T,M0,N,PNODES(I),RECUR,H0,NEXP,WT(I))
  3143.         IF(SYMMET) THEN
  3144.           WT(N-I+1)=WT(I)
  3145.         END IF
  3146. 20      CONTINUE
  3147. C Test the new rule
  3148.       DO 30 K=0,MIN(4,IDEG/2)
  3149.         CALL CHECK(N,PNODES,WT,K,H0,RECUR,TEST,IERR)
  3150.         IF(IERR.EQ.1) THEN
  3151.           IFLAG=6
  3152.           RETURN
  3153.         END IF
  3154. 30      CONTINUE
  3155.       RETURN
  3156.       END
  3157.       SUBROUTINE CHECK(N,QNODE,WT,K,H0,RECUR,TEST,IERR)
  3158.       IMPLICIT REAL*16 (A-H,O-Z)
  3159.       REAL*16 QNODE(*),WT(*),H0,TEST
  3160.       INTEGER N,K,IERR
  3161.       EXTERNAL RECUR
  3162. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3163. C FORTRAN-77 Version 2.2: March 1987
  3164. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3165. C Purpose:
  3166. C
  3167. C Carry out test of the given quadrature rule by computing the
  3168. C appropriate integral of,
  3169. C                     W(X)*P(K,X)*P(K,X)
  3170. C over the region associated with the weight function W(X) and the
  3171. C orthogonal polynomials P(K,X).
  3172. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3173. C Unless indicated otherwise the type of each variable is implied
  3174. C by the default FORTRAN-77 naming convention.
  3175. C
  3176. C Input parameters:
  3177. C
  3178. C N      = Number of nodes in the quadrature rule.
  3179. C QNODE  = Array holding the N nodes.
  3180. C WT     = Array holding the N weights.
  3181. C K      = Index of the orthogonal polynomial whose weighted square
  3182. C          is to be integrated.
  3183. C H0     = Integral of the orthogonality weight function over the
  3184. C          interval of integration. Zero moment integral. Note that
  3185. C          P(0,X) is arbitrarily taken to be 1.0.
  3186. C RECUR  = Name of the subroutine which defines the orthogonal
  3187. C          polynomials. See EXTEND for a full description.
  3188. C
  3189. C Output parameters:
  3190. C TEST   = Approximate value of the test integral normalised to
  3191. C          unity. Thus, ABS(TEST-1) gives a measure of the
  3192. C          quality of the calculated rule.
  3193. C IERR   = 0, OK.
  3194. C        = 1, Rule quality unsatisfactory
  3195. C        = 2, Invalid values for input arguments
  3196. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3197.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0,TOL=0.0000001Q0)
  3198.       IERR=0
  3199.       IF(K.LT.0 .OR. N.LT.1 .OR. H0.LE.ZERO) THEN
  3200.         IERR=2
  3201.         RETURN
  3202.       END IF
  3203.       TEST=ZERO
  3204.       DO 30 I=1,N
  3205.         P1=ONE
  3206.         IF(K.EQ.0) GOTO 20
  3207.         P0=ZERO
  3208.         X=QNODE(I)
  3209. C Calculate integrand
  3210.         DO 10 J=0,K-1
  3211.           CALL RECUR(J,CJ,DJ,EJ)
  3212.           P=(CJ*X+DJ)*P1+EJ*P0
  3213.           P0=P1
  3214.           P1=P
  3215. 10        CONTINUE
  3216. 20      TEST=TEST+P1*P1*WT(I)
  3217. 30      CONTINUE
  3218.       TEST=TEST/H0
  3219.       IF(K.EQ.0) RETURN
  3220. C Calculate exact value
  3221.       CALL RECUR(0,P,P0,P1)
  3222.       DO 70 J=1,K
  3223.         CALL RECUR(J,CJ,DJ,EJ)
  3224.         P=-P*EJ
  3225. 70      CONTINUE
  3226. C Normalise result to unity
  3227.       TEST=TEST*CJ/P
  3228. C Test for rule quality
  3229.       IF(ABS(TEST-ONE).GT.TOL) IERR=1
  3230.       RETURN
  3231.       END
  3232.       SUBROUTINE ASSIGN(N,PNODES,IWORK,WORK,LDW,RECUR,T,IERR)
  3233.       IMPLICIT REAL*16 (A-H,O-Z)
  3234.       REAL*16 PNODES(*),WORK(0:LDW-1,0:*),T(0:*)
  3235.       INTEGER N,LDW,IERR,IWORK(*)
  3236.       EXTERNAL RECUR
  3237. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3238. C Purpose:
  3239. C
  3240. C Generate the initial polynomial T whose roots are the required
  3241. C pre-assigned nodes
  3242. C
  3243. C Unless indicated otherwise the type of each variable is implied
  3244. C by the default FORTRAN-77 naming convention.
  3245. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3246. C Input parameters:
  3247. C N      = Number of pre-assigned nodes to be used to generate T.
  3248. C PNODES = Array holding N pre-assigned nodes to be be used to
  3249. C          generate T.
  3250. C IWORK  = Integer working array which should be declared in the
  3251. C          calling program to have at least N elements.
  3252. C WORK   = Real working matrix which should be declared in
  3253. C          the calling program to have dimension at least N by
  3254. C          N+1.
  3255. C LDW    = Number of elements in the leading dimension of WORK
  3256. C          declared in the calling program
  3257. C RECUR  = Name of user supplied subroutine which defines the orthogonal
  3258. C          polynomials. Given K, CALL RECUR(K,C,D,E) gives
  3259. C          the coefficients C,D and E such that,
  3260. C                      P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  3261. C          The parameters are defined as follows:
  3262. C             K = Index
  3263. C             C,D,E = Parameters in the recurrence relation
  3264. C                                              (functions of K)
  3265. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3266. C Output parameters:
  3267. C T      = Array holding the coefficients of the polynomial whose
  3268. C          roots define the pre-assigned nodes of the quadrature
  3269. C          rule and expressed as:
  3270. C                  H0* SUM (I=0 to N) T(I)/HI*P(I,X)
  3271. C          T(I) holds the value of TI.
  3272. C          This array should be declared to have at least N+1 elements
  3273. C          in the calling program.
  3274. C IERR   = 0, No error detected
  3275. C        = 1, The linear system of equations used to generate the
  3276. C             polynomial T became singular or very ill-conditioned. (FAT
  3277. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3278. C External library routines called: LINPACK - DGEFA, DGESL
  3279. C FORTRAN-77 versions of these are used and renamed GEFA77 and GESL77.
  3280. C Note -- These call the BLAS routines DSCAL, IDAMAX, DAXPY and DDOT
  3281. C which are not renamed.
  3282. C (Quadruple precision versions used for this subprogram)
  3283. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3284.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  3285.       IERR=0
  3286. C Set up the linear system of equations
  3287.       DO 20 J=1,N
  3288.         X=PNODES(J)
  3289.         P0=ZERO
  3290.         P1=ONE
  3291.         P=P1
  3292.         DO 10 K=0,N
  3293.           WORK(J-1,K)=P
  3294.           CALL RECUR(K,C0,D0,E0)
  3295.           P=(C0*X+D0)*P1+E0*P0
  3296.           P0=P1
  3297.           P1=P
  3298. 10        CONTINUE
  3299. 20      CONTINUE
  3300. C Solve linear system
  3301.       CALL GEFA77(WORK,LDW,N,IWORK,INFO)
  3302.       IF(INFO.NE.0) THEN
  3303.         IERR=1
  3304.         RETURN
  3305.       END IF
  3306.       CALL GESL77(WORK,LDW,N,IWORK,WORK(0,N),0)
  3307.       DO 30 J=0,N-1
  3308.         T(J)=-WORK(J,N)
  3309. 30      CONTINUE
  3310.       T(N)=ONE
  3311. C Weight with moments
  3312.       CALL TRANSF(T,0,N,RECUR,1)
  3313.       RETURN
  3314.       END
  3315.       SUBROUTINE GENER(T,M0,N,M,RECUR,SYMMET,EXT,
  3316.      *                          IWORK,WORKA,LDA,WORKB,LDB,IFLAG)
  3317.       IMPLICIT REAL*16 (A-H,O-Z)
  3318.       REAL*16 WORKA(0:LDA-1,0:*),WORKB(0:LDB-1,*)
  3319.       REAL*16 T(0:*),EXT(0:*)
  3320.       INTEGER M0,N,M,IWORK(*),LDA,LDB,IFLAG
  3321.       LOGICAL SYMMET
  3322. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3323. C Purpose:
  3324. C
  3325. C Given N pre-assigned quadrature nodes defined as the roots of the
  3326. C polynomial expansion,
  3327. C                   SUM (I=M0 to N) (TI/HI)*P(I,X)
  3328. C calculate the polynomial expansion,
  3329. C                   SUM (I=0 to M) SI*P(I,X)
  3330. C whose roots are the M optimal nodes and new expansion
  3331. C                   SUM (I=M to N+M) (RI/HI)*P(I,X)
  3332. C whose roots are to the N+M nodes of the full extended quadrature rule.
  3333. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3334. C Unless indicated otherwise the type of each variable is implied
  3335. C by the default FORTRAN-77 naming convention.
  3336. C
  3337. C Input parameters:
  3338. C T     = Array holding the coefficients TI of the polynomial whose
  3339. C         roots define the N pre-assigned nodes of the quadrature
  3340. C         rule and expressed as:
  3341. C                  SUM (I=M0 to N) (TI/HI)*P(I,X)
  3342. C         where HI is the integral of W(X)*P(I,X)**2 over the
  3343. C         interval for which orthogonality with respect the weight
  3344. C         W(X) is defined (moment integrals) and P(I,X) is the
  3345. C         orthogonal polynomial of degree I. T(I-M0) holds the
  3346. C         value of TI. This array should be declared to have at least
  3347. C         max(N-M0+1,M+1) elements in the calling program.
  3348. C M0    = Lower limit to the expansion of T.
  3349. C N     = Upper limit to expansion of T.
  3350. C M     = Number of nodes to be optimally added.
  3351. C RECUR = Name of user supplied subroutine which defines the orthogonal
  3352. C         polynomials. Given K, CALL RECUR(K,C,D,E) gives
  3353. C         the coefficients C,D and E such that,
  3354. C                     P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  3355. C           The parameters are defined as follows:
  3356. C             K = Index
  3357. C             C,D,E = Parameters in the recurrence relation
  3358. C                                                (functions of K)
  3359. C SYMMET=  .FALSE. if no advantage is to be taken of symmetry, if any,
  3360. C          about x=0 in the interval of integration and the
  3361. C          orthogonality  weight function. Note that if symmetry in
  3362. C          fact does exist setting this parameter to zero will still
  3363. C          produce correct results - only efficiency is effected.
  3364. C       =  .TRUE. if the extended rule computations should
  3365. C          exploit symmetry about x=0 in the interval of
  3366. C          integration and the orthogonality  weight function.
  3367. C          This reduces the size of the system of linear equations
  3368. C          determining EXT by a factor of about 2 (see WORKA). If
  3369. C          symmetry does not in fact exist erroneous results will be
  3370. C          produced.
  3371. C IWORK  = Integer working array which should be declared in the
  3372. C          calling program to have at least M elements.
  3373. C WORKA  = Real working matrix which should be declared in the calling
  3374. C          program to have dimension at least M+1 by max(M+1,N+1).
  3375. C          If SYMMET=.TRUE. (see above) the dimension can be reduced to
  3376. C          M/2+1 by max(M/2+1,N/2+1).
  3377. C LDA    = Number of elements in the leading dimension of WORKA
  3378. C          declared in the calling program
  3379. C WORKB  = Real working matrix which should be declared in the calling
  3380. C          program to have at dimension at least 2*M+1 by 3.
  3381. C LDB    = Number of elements in the leading dimension of WORKB
  3382. C          declared in the calling program.
  3383. C
  3384. C Output parameters:
  3385. C T      = Array holding the coefficients of the new orthogonal
  3386. C          expansion whose roots are the nodes of the extended quadratur
  3387. C          (that is the pre-assigned nodes plus the extended nodes).
  3388. C          It is expressed as:
  3389. C                  SUM (I=M to N+M) (TI/HI)*P(I,X)
  3390. C          where N and M have their original values. T(I-M) holds
  3391. C          the value of TI. See input argument of T for definitions.
  3392. C M0,N   = Lower and upper limits defining the new orthogonal expansion
  3393. C EXT    = Array holding the coefficients of the polynomial whose
  3394. C          roots are the  new extended nodes and expressed as:
  3395. C                EXT =   SUM (I=0 to M) EXT(I)*P(I,X)
  3396. C IFLAG  = 0, No error detected
  3397. C        = 1, The linear system of equations defining the polynomial
  3398. C             whose roots are the extended nodes became singular or
  3399. C             very  ill-conditioned.   (FATAL).
  3400. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3401. C External library routines called: LINPACK - DGEFA, DGESL
  3402. C FORTRAN-77 versions of these are used and renamed GEFA77 and GESL77.
  3403. C Note -- These call the BLAS routines DSCAL, IDAMAX, DAXPY and DDOT
  3404. C which are not renamed.
  3405. C (Quadruple precision versions used for this subprogram)
  3406. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3407.       LOGICAL NEVEN,MSODD,MISS
  3408.       EXTERNAL RECUR
  3409.       INTEGER S
  3410.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  3411.       IFLAG=0
  3412. C Look for trivial case
  3413.       IF(N.EQ.0) THEN
  3414.         DO 10 I=0,M-1
  3415.           EXT(I)=ZERO
  3416. 10        CONTINUE
  3417.         EXT(M)=ONE
  3418.         T(0)=ONE
  3419.         N=M
  3420.         M0=M
  3421.         RETURN
  3422.       END IF
  3423. C General case
  3424.       NEVEN=MOD(N,2).EQ.0
  3425.       NM=N+M
  3426. C Form matrix
  3427. 20    DO 60 S=0,M
  3428.         MSODD=MOD(M+S,2).EQ.1
  3429.         IF(NEVEN.AND.MSODD.AND.SYMMET) GOTO 60
  3430.         DO 50 J=0,S
  3431.           CALL EPROD(S,J,WORKB(0,1),WORKB(0,2),LDB,RECUR,IFAIL)
  3432.           IF(MOD(N+S+J,2).EQ.1.AND.SYMMET) GOTO 50
  3433.           IREF=S-J
  3434.           ITOP=MIN(N,J+S)
  3435.           IBOT=MAX(M0,IREF)
  3436.           SUM=ZERO
  3437.           IF(IBOT.GT.ITOP) GOTO 40
  3438.           DO 30 I=IBOT,ITOP
  3439.             SUM=SUM+T(I-M0)*WORKB(I-IREF,1)
  3440. 30          CONTINUE
  3441. 40        IF(.NOT.SYMMET) THEN
  3442.             WORKA(S,J)=SUM
  3443.             WORKA(J,S)=SUM
  3444.             GOTO 50
  3445.           END IF
  3446.           IF(NEVEN) THEN
  3447.             WORKA(S/2,J/2)=SUM
  3448.             WORKA(J/2,S/2)=SUM
  3449.           ELSE
  3450.             IF(MSODD) THEN
  3451.               WORKA(S/2,J/2)=SUM
  3452.             ELSE
  3453.               WORKA(J/2,S/2)=SUM
  3454.             END IF
  3455.           END IF
  3456. 50        CONTINUE
  3457. 60      CONTINUE
  3458.       NEQ=M
  3459.       IF(SYMMET) NEQ=M/2
  3460. C Solve for expansion coefficients
  3461.       CALL GEFA77(WORKA,LDA,NEQ,IWORK,INFO)
  3462.       IF(INFO.NE.0) THEN
  3463.         IFLAG=1
  3464.         RETURN
  3465.       END IF
  3466.       CALL GESL77(WORKA,LDA,NEQ,IWORK,WORKA(0,NEQ),0)
  3467. C Store expansion coefficients
  3468.       DO 70 J=0,NEQ-1
  3469.         EXT(J)=-WORKA(J,NEQ)
  3470. 70      CONTINUE
  3471.       EXT(NEQ)=ONE
  3472. C Calculate new T polynomial
  3473.       IF(SYMMET) GOTO 160
  3474. C
  3475. C Non-symmetric case
  3476.       DO 140 S=M,NM
  3477.         IF(S.EQ.M) GOTO 120
  3478.         DO 110 J=0,M
  3479.           CALL EPROD(S,J,WORKB(0,1),WORKB(0,2),LDB,RECUR,IFAIL)
  3480.           IREF=S-J
  3481.           ITOP=MIN(N,J+S)
  3482.           IBOT=MAX(M0,IREF)
  3483.           SUM=ZERO
  3484.           IF(IBOT.GT.ITOP) GOTO 100
  3485.           DO 90 I=IBOT,ITOP
  3486.             IR=I-IREF
  3487.             SUM=SUM+T(I-M0)*WORKB(I-IREF,1)
  3488. 90          CONTINUE
  3489. 100       WORKA(M,J)=SUM
  3490. 110       CONTINUE
  3491. 120     SUM=ZERO
  3492.         DO 130 I=0,M
  3493.           SUM=SUM+EXT(I)*WORKA(M,I)
  3494. 130       CONTINUE
  3495.         WORKA(M-1,S-M)=SUM
  3496. 140     CONTINUE
  3497. C Overwrite old values of T
  3498.       DO 150 I=0,N
  3499.         T(I)=WORKA(M-1,I)
  3500. 150     CONTINUE
  3501.       GOTO 250
  3502. C
  3503. C Symmetric case
  3504. 160   DO 210 S=M,NM
  3505.         IF(MOD(N+M+S,2).EQ.1) GOTO 210
  3506.         DO 190 J=0,M
  3507.           CALL EPROD(S,J,WORKB(0,1),WORKB(0,2),LDB,RECUR,IFAIL)
  3508.           IF(MOD(N+S+J,2).EQ.1) GOTO 190
  3509.           IREF=S-J
  3510.           ITOP=MIN(N,J+S)
  3511.           IBOT=MAX(M0,IREF)
  3512.           SUM=ZERO
  3513.           IF(IBOT.GT.ITOP) GOTO 180
  3514.           DO 170 I=IBOT,ITOP
  3515.             IR=I-IREF
  3516.             SUM=SUM+T(I-M0)*WORKB(I-IREF,1)
  3517. 170         CONTINUE
  3518. 180       WORKA(NEQ,J/2)=SUM
  3519. 190     CONTINUE
  3520.       SUM=ZERO
  3521.       DO 200 I=0,NEQ
  3522.         SUM=SUM+EXT(I)*WORKA(NEQ,I)
  3523. 200     CONTINUE
  3524.       WORKA(NEQ-1,(S-M)/2)=SUM
  3525. 210   CONTINUE
  3526. C Overwrite old values of T in full unsymmetric form
  3527.       IC=N/2
  3528.       MISS=.TRUE.
  3529.       DO 220 J=N,0,-1
  3530.         MISS=.NOT.MISS
  3531.         IF(MISS) THEN
  3532.           T(J)=ZERO
  3533.         ELSE
  3534.           T(J)=WORKA(NEQ-1,IC)
  3535.           IC=IC-1
  3536.         END IF
  3537. 220     CONTINUE
  3538. C Convert EXT to full unsymmetric form
  3539.       WORKB(M,1)=ONE
  3540.       IC=NEQ-1
  3541.       MISS=.FALSE.
  3542.       DO 230 J=M-1,0,-1
  3543.         MISS=.NOT.MISS
  3544.         IF(MISS) THEN
  3545.           WORKB(J,1)=ZERO
  3546.         ELSE
  3547.           WORKB(J,1)=EXT(IC)
  3548.           IC=IC-1
  3549.         END IF
  3550. 230     CONTINUE
  3551.       DO 240 J=0,M
  3552.         EXT(J)=WORKB(J,1)
  3553. 240     CONTINUE
  3554. C Scale new T polynomial
  3555. 250   PMAX=ZERO
  3556.       DO 260 I=0,N
  3557.         PMAX=MAX(PMAX,ABS(T(I)))
  3558. 260     CONTINUE
  3559.       DO 270 I=0,N
  3560.         T(I)=T(I)/PMAX
  3561. 270     CONTINUE
  3562.       N=NM
  3563.       M0=M
  3564.       RETURN
  3565.       END
  3566.       SUBROUTINE SOLVE(EXT,M,SYMMET,RECUR,IDIGIT,QRNODE,QINODE,
  3567.      *                 NODES,ERR,ICHECK,WORK,LDW,IERR)
  3568.       IMPLICIT REAL*16 (A-H,O-Z)
  3569.       REAL*16 EXT(0:*),WORK(0:LDW-1,*),ERR(*)
  3570.       REAL*16 QRNODE(*),QINODE(*)
  3571.       INTEGER M,NODES,LDW,IERR,ICHECK(*),IDIGIT
  3572.       LOGICAL SYMMET,RESET
  3573.       EXTERNAL RECUR
  3574. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3575. C Purpose:
  3576. C
  3577. C Calculate the roots of the orthogonal polynomial expansion
  3578. C expressed as,
  3579. C                 SUM (I=0 to M) EXT(I)*P(I,X)
  3580. C where the array EXT holds the appropriate coefficients.
  3581. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3582. C Unless indicated otherwise the type of each variable is implied
  3583. C by the default FORTRAN-77 naming convention.
  3584. C
  3585. C Input parameters:
  3586. C EXT    = Array holding the coefficients of the polynomial whose
  3587. C          roots are required (nodes of the quadrature rule)
  3588. C          and expressed as:
  3589. C                    SUM (I=0 to M) EXT(I)*P(I,X)
  3590. C          The recurrence relation for the orthogonal polynomials
  3591. C          P(I,X) is defined by the subroutine RECUR.
  3592. C          This array should be declared to have at least M+1 elements
  3593. C          in the calling program.
  3594. C M      = Upper limit to expansion EXT (polynomial degree).
  3595. C SYMMET = .FALSE. if no advantage can be taken of symmetry
  3596. C          about x=0 in the interval of integration and the
  3597. C          orthogonality  weight function.
  3598. C        = .TRUE. if symmetry exists about x=0 in the interval of
  3599. C          integration and the orthogonality weight function.
  3600. C RECUR  = Name of user supplied subroutine which defines the orthogonal
  3601. C          polynomials. Given K, CALL RECUR(K,C,D,E) gives
  3602. C          the coefficients C,D and E such that,
  3603. C                      P(K+1,X)=(C*X+D)*P(K,X)+E*P(K-1,X)
  3604. C          The parameters are defined as follows:
  3605. C             K = Index
  3606. C             C,D,E = Parameters in the recurrence relation
  3607. C                                              (functions of K)
  3608. C IDIGIT = Node convergence parameter (integer greater than 0).
  3609. C          An attempt is made to calculate the nodes to the maximum
  3610. C          accuracy possible by the machine precision available.
  3611. C          IDIGIT controls the assessment procedure to take account of
  3612. C          round-off errors and specifies the number of least significan
  3613. C          decimal digits that can be ignored (i.e. attributed
  3614. C          to round-off) in the computed relative error. Typical
  3615. C          value is 5.
  3616. C WORK   = Real working matrix which should be declared in the calling
  3617. C          program to have dimension at least M+1 by 2.
  3618. C LDW    = Number of elements in the leading dimension of WORK
  3619. C          declared in the calling program
  3620. C
  3621. C Output parameters:
  3622. C
  3623. C QRNODE = Array holding the real parts of the roots fo EXT (1,..,NODES)
  3624. C QINODE = Array holding the imaginary parts of the roots of EXT (1,..,N
  3625. C          (hopefully these values are zero!).
  3626. C NODES  = Number of extended nodes found. Normally equals M but see IER
  3627. C ICHECK = Root convergence flags. Elements 1 to NODES give information
  3628. C          on the convergence of the roots of the polynomial EXT.
  3629. C            Element I = 0 Convergence of I th root satisfactory
  3630. C            Element I = 1 Convergence of I th root unsatisfactory
  3631. C          This array should be declared to have at least M elements
  3632. C          in the calling program.
  3633. C IERR   = 0, No error detected
  3634. C        = 1, Possible imaginary nodes detected.
  3635. C        = 2, Poor convergence has been detected in the calculation
  3636. C             of the roots of EXT (see above) or all roots have not
  3637. C             been found (M not equal to NODES). See also ERR(*) below.
  3638. C ERR    = Array holding a measure of the relative error in the
  3639. C          roots. This may be inspected if the convergence
  3640. C          error flag has been raised (IERR=2) to decide if the roots
  3641. C          in question are acceptable. (ERR(*) actually gives the mean
  3642. C          last correction to the quadratic factor in the generalised
  3643. C          Bairstow root finder (see BAIR). This should declared in
  3644. C          the calling program to have at least M elements.
  3645. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3646.       PARAMETER (ZERO=0.0Q0,HALF=0.5Q0,ONE=1.0Q0,
  3647.      *           TWO=2.0Q0,VRT1=0.0000001Q0)
  3648.       NODES=0
  3649.       IERR=0
  3650. C If M is odd find and remove initial real root using NEWTON iteration
  3651. C Set WORK(*,1) to polynomial to be processed
  3652.       IF(MOD(M,2).EQ.1) THEN
  3653.         ZR1=VRT1
  3654.         CALL NEWTON(EXT,M,ZR1,RECUR,IDIGIT,WORK(0,1),ERRVAL,IFAIL)
  3655.         NODES=NODES+1
  3656.         ICHECK(NODES)=IFAIL
  3657.         ERR(NODES)=ERRVAL
  3658.         QRNODE(NODES)=ZR1
  3659.         QINODE(NODES)=ZERO
  3660.         NROOT=M-1
  3661.       ELSE
  3662.         DO 10 I=0,M
  3663.           WORK(I,1)=EXT(I)
  3664. 10        CONTINUE
  3665.         NROOT=M
  3666.       END IF
  3667.       IF(NROOT.EQ.0) GOTO 50
  3668. C Find remaining root pairs
  3669. C Calculate seed approximation for quadratic factor
  3670.       CALL RECUR(0,C0,D0,E0)
  3671.       CALL RECUR(1,C1,D1,E1)
  3672.       RT1=VRT1
  3673.       RT2=ZERO
  3674.       IF(SYMMET) RT2=-RT1
  3675.       P1A=C0*RT1+D0
  3676.       P1B=C0*RT2+D0
  3677.       P2A=(C1*RT1+D1)*P1A+E1
  3678.       P2B=(C1*RT2+D1)*P1B+E1
  3679.       DET=C0*(RT1-RT2)
  3680.       SA1=(P2A-P2B)/DET
  3681.       SA0=(P1A*P2B-P1B*P2A)/DET
  3682.       RESET=.TRUE.
  3683. C Alternate approximation which introduces small complex component
  3684.       RT1=VRT1
  3685.       RT2=VRT1
  3686.       SFA1=(C0*D1+D0*C1)/C0+TWO*C1*RT1
  3687.       SFA0=D0*D1+E1-D0*SFA1-C0*C1*(RT1*RT1+RT2*RT2)
  3688. C IP1 points to current deflated polynomial
  3689.       IP1=1
  3690.       IP2=2
  3691. 20    IF(RESET) THEN
  3692.         A2=ONE
  3693.         A1=SA1
  3694.         A0=SA0
  3695.         RESET=.FALSE.
  3696.       END IF
  3697.       CALL BAIR(NROOT,WORK(0,IP1),WORK(0,IP2),A0,A1,A2,
  3698.      *                                     RECUR,IDIGIT,ERRVAL,IFAIL)
  3699.       IF(IFAIL.NE.0) THEN
  3700. C Try again with complex components introduced
  3701.         A2=ONE
  3702.         A1=SFA1
  3703.         A0=SFA0
  3704.         RESET=.TRUE.
  3705.         CALL BAIR(NROOT,WORK(0,IP1),WORK(0,IP2),A0,A1,A2,
  3706.      *                                     RECUR,IDIGIT,ERRVAL,IFAIL)
  3707.       END IF
  3708. C Apply Bairstow to full expansion to avoid error accumulation
  3709.       CALL BAIR(M,EXT,WORK(0,IP2),A0,A1,A2,
  3710.      *                                     RECUR,IDIGIT,ERRVAL,IFAIL)
  3711. C Tidy up the quotient polynomial
  3712.       CALL QFACT(NROOT,WORK(0,IP1),WORK(0,IP2),RECUR,A1,A0,
  3713.      *                                       ZR1,ZR1,ZR1,ZR1,ZR1,ZR1)
  3714.       CALL ROOTS(A0,A1,A2,ZR1,ZI1,ZR2,ZI2,RECUR,INFO)
  3715. C Record node information
  3716.       NODES=NODES+1
  3717.       ICHECK(NODES)=IFAIL
  3718.       ERR(NODES)=ERRVAL
  3719.       QRNODE(NODES)=ZR1
  3720.       QINODE(NODES)=ZI1
  3721.       NODES=NODES+1
  3722.       ICHECK(NODES)=IFAIL
  3723.       ERR(NODES)=ERRVAL
  3724.       QRNODE(NODES)=ZR2
  3725.       QINODE(NODES)=ZI2
  3726.       NROOT=NROOT-2
  3727. C Make the deflated polynomial current
  3728.       I=IP1
  3729.       IP1=IP2
  3730.       IP2=I
  3731.       IF(NROOT.GT.0) THEN
  3732. C Scale the deflated polynomial
  3733.         PMAX=ZERO
  3734.         DO 30 I=0,NROOT
  3735.           PMAX=MAX(PMAX,ABS(WORK(I,IP1)))
  3736. 30        CONTINUE
  3737.         DO 40 I=0,NROOT
  3738.           WORK(I,IP1)=WORK(I,IP1)/PMAX
  3739. 40        CONTINUE
  3740.         GOTO 20
  3741.       END IF
  3742. C Calculation complete - Check for difficulties
  3743. C Look for poor convergence
  3744. 50    I=0
  3745.       DO 60 J=1,NODES
  3746.         I=I+ICHECK(J)
  3747. 60      CONTINUE
  3748.       IF(NODES.NE.M.OR.I.NE.0) THEN
  3749.         IERR=1
  3750.         RETURN
  3751.       END IF
  3752. C Look for possible imaginary nodes
  3753.       DO 70 J=1,NODES
  3754.         IF(QINODE(J).NE.ZERO) THEN
  3755.           IERR=2
  3756.           RETURN
  3757.         END IF
  3758. 70      CONTINUE
  3759.       RETURN
  3760.       END
  3761.       SUBROUTINE RSORT(A,N,IFLAG)
  3762.       IMPLICIT REAL*16 (A-H,O-Z)
  3763.       REAL*16 A(*)
  3764.       INTEGER N,IFLAG
  3765. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3766. C FORTRAN-77 Version 2.2: March 1987
  3767. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3768. C Purpose:
  3769. C Carries out a simple ripple sort of A(*).
  3770. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3771. C Unless indicated otherwise the type of each variable is implied
  3772. C by the default FORTRAN-77 naming convention.
  3773. C
  3774. C Input parameters:
  3775. C A     = Array holding the numbers to be sorted
  3776. C N     = Number of elements to be sorted
  3777. C IFLAG = 0 for ascending sort
  3778. C       = 1 for descending sort
  3779. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3780.       LOGICAL DONE,ASCEND
  3781.       ASCEND=IFLAG.EQ.0
  3782. C Begin scans
  3783.       DO 30 J=N-1,1,-1
  3784.         DONE=.TRUE.
  3785.         DO 20 K=1,J
  3786.           IF(ASCEND) THEN
  3787.             K1=K
  3788.             K2=K+1
  3789.           ELSE
  3790.             K1=K+1
  3791.             K2=K
  3792.           END IF
  3793.           IF(A(K1).GT.A(K2)) THEN
  3794. C Exchange elements
  3795.             VAL=A(K1)
  3796.             A(K1)=A(K2)
  3797.             A(K2)=VAL
  3798.             DONE=.FALSE.
  3799.           END IF
  3800. 20        CONTINUE
  3801.         IF(DONE) RETURN
  3802. 30    CONTINUE
  3803.       RETURN
  3804.       END
  3805.       SUBROUTINE WEIGHT(T,M,N,XNODE,RECUR,H0,NEXP,WT)
  3806.       IMPLICIT REAL*16 (A-H,O-Z)
  3807.       REAL*16 T(0:*),XNODE,H0,WT
  3808.       INTEGER M,N,NEXP
  3809.       EXTERNAL RECUR
  3810. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3811. C FORTRAN-77 Version 2.2: March 1987
  3812. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3813. C Purpose:
  3814. C
  3815. C Calculates the quadrature weight associated with the node XNODE in the
  3816. C rule whose nodes are defined by the roots of polynomial T.
  3817. C
  3818. C The weight is calculated by dividing T by (X-XNODE) to give,
  3819. C
  3820. C S(X) = T(X)/(X-XNODE) = SUM (0 to N-1) G(I)*P(I,X).
  3821. C
  3822. C S(X) is then divided by (X-XNODE) to give remainder R.
  3823. C
  3824. C The weight is finally given by H0*G(0)/R. If N=M the
  3825. C Christoffel-Darboux identity result is used to reduce extreme
  3826. C cancellation effects at high degree.
  3827. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3828. C Unless indicated otherwise the type of each variable is implied
  3829. C by the default FORTRAN-77 naming convention.
  3830. C
  3831. C Input parameters:
  3832. C
  3833. C T      = Array holding the coefficients TI of the polynomial whose
  3834. C          roots define the N pre-assigned nodes of the quadrature
  3835. C          rule and expressed as:
  3836. C                   SUM (I=M to N) (TI/HI)*P(I,X)
  3837. C          where HI is the integral of W(X)*P(I,X)**2 over the
  3838. C          interval for which orthogonality with respect the weight
  3839. C          W(X) is defined (moment integrals) and P(I,X) is the
  3840. C          orthogonal polynomial of degree I. T(I-M) holds the
  3841. C          value of TI. This array should be declared to have at least
  3842. C          N-M+1 elements in the calling program.
  3843. C M      = Lower limit to the expansion of T
  3844. C N      = Upper limit to expansion of T
  3845. C XNODE  = Node whose weight is required
  3846. C RECUR  = Name of the subroutine which defines the orthogonal
  3847. C          polynomials. See EXTEND for a full description.
  3848. C H0     = Integral of the orthogonality weight function over the
  3849. C          interval of integration. Zero moment integral. Note that
  3850. C          P(0,X) is arbitrarily taken to be 1.0
  3851. C NEXP   = Largest negative decimal exponent supported on the
  3852. C          computer. (Positive number - typical value 38).
  3853. C          Weights less than approximately 10**(-NEXP) are set to zero
  3854. C          when the Christoffel-Darboux identity is used (N=M).
  3855. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3856. C Output parameters:
  3857. C WT    = Weight associated with XNODE.
  3858. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3859.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0,TEN=10.0Q0)
  3860. C Check for special case
  3861.       IF(M.EQ.N) THEN
  3862. C Use Christoffel-Darboux result
  3863.         BK1=ZERO
  3864.         BK2=ONE
  3865.         DK1=ZERO
  3866.         DK2=ZERO
  3867.         ISCALE=0
  3868.         CALL RECUR(0,H,D0,E0)
  3869.         DO 20 K=0,N-1
  3870.           CALL RECUR(K,CK,DK,EK)
  3871.           IF(K.NE.0) H=-EK*H
  3872.           BB=(CK*XNODE+DK)*BK2+EK*BK1
  3873.           DD=(CK*XNODE+DK)*DK2+EK*DK1+CK*BK2
  3874.           BK1=BK2
  3875.           BK2=BB
  3876.           DK1=DK2
  3877.           DK2=DD
  3878.           IF(BK2.NE.ZERO) THEN
  3879.             J=LOG10(ABS(BK2))
  3880.             IF(ABS(J).GT.2) THEN
  3881. C Scale to control overflow/underflow
  3882.               ISCALE=ISCALE-2*J
  3883.               SCALE=TEN**J
  3884.               BK2=BK2/SCALE
  3885.               BK1=BK1/SCALE
  3886.               DK1=DK1/SCALE
  3887.               DK2=DK2/SCALE
  3888.             END IF
  3889.           END IF
  3890.           IF(H.NE.ZERO) THEN
  3891.             J=LOG10(ABS(H))
  3892.             IF(ABS(J).GE.2) THEN
  3893.               ISCALE=ISCALE+J
  3894.               H=H/TEN**J
  3895.             END IF
  3896.           END IF
  3897. 20        CONTINUE
  3898.         WT=H0*H/DK2/BK1
  3899.         IF(WT.NE.ZERO) THEN
  3900.           ITEST=LOG10(ABS(WT))+ISCALE
  3901.           IF(ITEST.GE.-NEXP) THEN
  3902.             WT=WT*TEN**ISCALE
  3903.           ELSE
  3904.             WT=ZERO
  3905.           END IF
  3906.         END IF
  3907.         RETURN
  3908.       END IF
  3909. C General case
  3910.       BK2=ZERO
  3911.       BK1=ZERO
  3912.       RK2=ZERO
  3913.       RK1=ZERO
  3914.       CALL RECUR(N,CK,DK,EK)
  3915.       CALL RECUR(N+1,CK1,DK1,EK1)
  3916.       H=ONE
  3917.       ISCALE=0
  3918.       DO 10 K=N,1,-1
  3919.         IF(K.GE.M) THEN
  3920.           RS=T(K-M)/H
  3921. C Scale and adjust for possible overflow/underflow
  3922.           IF(ISCALE.GT.NEXP) THEN
  3923.             RS=ZERO
  3924.           ELSE
  3925.             RS=RS/TEN**ISCALE
  3926.           END IF
  3927.         ELSE
  3928.           RS=ZERO
  3929.         END IF
  3930.         BB=RS+(DK+XNODE*CK)*BK1+EK1*BK2
  3931.         BK2=BK1
  3932.         BK1=BB
  3933.         CALL RECUR(K-1,CKM1,DKM1,EKM1)
  3934.         IF(N.NE.M) H=-H*CK/EK/CKM1
  3935.         BB=BB*CKM1
  3936.         WT=BB+(DKM1+XNODE*CKM1)*RK1+EK*RK2
  3937.         RK2=RK1
  3938.         RK1=WT
  3939.         CK1=CK
  3940.         DK1=DK
  3941.         EK1=EK
  3942.         CK=CKM1
  3943.         DK=DKM1
  3944.         EK=EKM1
  3945.         IF(BK1.NE.ZERO) THEN
  3946.           J=LOG10(ABS(BK1))
  3947.           IF(ABS(J).GT.2) THEN
  3948. C Scale to control overflow/underflow
  3949.             ISCALE=ISCALE+J
  3950.             SCALE=TEN**J
  3951.             BK1=BK1/SCALE
  3952.             BK2=BK2/SCALE
  3953.             RK1=RK1/SCALE
  3954.             RK2=RK2/SCALE
  3955.           END IF
  3956.         END IF
  3957. 10      CONTINUE
  3958.       WT=H0*BB/WT
  3959.       RETURN
  3960.       END
  3961.       SUBROUTINE TRANSF(T,M,N,RECUR,IFLAG)
  3962.       IMPLICIT REAL*16 (A-H,O-Z)
  3963.       REAL*16 T(0:*)
  3964.       INTEGER M,N
  3965.       EXTERNAL RECUR
  3966. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3967. C FORTRAN-77 Version 2.2: March 1987
  3968. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3969. C Purpose:
  3970. C
  3971. C Scales the polynomial expansion:
  3972. C          SUM (M to N) TI*P(I,X).
  3973. C with respect to the moments HI of the orthogonality weight function
  3974. C giving the expansion:
  3975. C          H0* SUM (M to N) (TI/HI)*P(I,X).
  3976. C or
  3977. C      (1/H0)* SUM (M to N) (TI*HI)*P(I,X).
  3978. C depending on the value of IFLAG.
  3979. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3980. C Unless indicated otherwise the type of each variable is implied
  3981. C by the default FORTRAN-77 naming convention.
  3982. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3983. C Input parameters:
  3984. C
  3985. C T      = Array holding the coefficients TI of the polynomial expansion
  3986. C          to be scaled and expressed as:
  3987. C                   SUM (I=M to N) TI*P(I,X)
  3988. C          T(I-M) holds the value of TI. T(*) should be declared to
  3989. C          have at least N-M+1 elements in the calling program.
  3990. C M      = Lower limit to the expansion of T
  3991. C N      = Upper limit to expansion of T
  3992. C RECUR  = Name of the subroutine which defines the orthogonal
  3993. C          polynomials. See EXTEND for a full description.
  3994. C IFLAG  = 0, if coefficient TI is to be replaced by TI*(H0/HI).
  3995. C IFLAG  = 1, if coefficient TI is to be replaced by TI*(HI/H0).
  3996. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  3997. C Output parameters:
  3998. C T      = Array holding the coefficients of the scaled polynomial
  3999. C          expansion.
  4000. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4001.       PARAMETER (ONE=1.0Q0)
  4002.       H=ONE
  4003.       DO 10 K=0,N
  4004.         CALL RECUR(K,CK,DK,EK)
  4005.         IF(K.NE.0) H=-CKM1/CK*EK*H
  4006.         IF(K.GE.M) THEN
  4007.           IF(IFLAG.EQ.0) THEN
  4008.             T(K-M)=T(K-M)/H
  4009.           ELSE
  4010.             T(K-M)=T(K-M)*H
  4011.           END IF
  4012.         END IF
  4013.         CKM1=CK
  4014. 10      CONTINUE
  4015.       RETURN
  4016.       END
  4017.       SUBROUTINE BAIR(N,POLIN,POLOUT,A0,A1,A2,RECUR,IDIGIT,ERRVAL,IFAIL)
  4018.       IMPLICIT REAL*16 (A-H,O-Z)
  4019.       REAL*16 POLIN(0:*),POLOUT(0:*),A0,A1,A2,ERRVAL
  4020.       INTEGER N,IDIGIT,IFAIL
  4021.       EXTERNAL RECUR
  4022. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4023. C FORTRAN-77 Version 2.2: March 1987
  4024. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4025. C Purpose:
  4026. C
  4027. C Generalised Bairstow root extraction for polynomial
  4028. C        SUM(I=0 to N)  POLIN(I)*P(I,X)
  4029. C Calculates root as quadratic factor,
  4030. C        A2*P(2,X)-A1*P(1,X)-A0*P(0,X)
  4031. C where P(I,X) is a general orthogonal polynomial of degree I
  4032. C
  4033. C (Reference: Golub & Robertson, Comm.ACM.,10,1967,371-373).
  4034. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4035. C Unless indicated otherwise the type of each variable is implied
  4036. C by the default FORTRAN-77 naming convention.
  4037. C
  4038. C Input parameters:
  4039. C
  4040. C N        = Degree of input polynomial POLIN
  4041. C POLIN    = Coefficients of polynomial of degree N whose quadratic
  4042. C            factor is to be found, i.e.
  4043. C                POLIN = SUM(I=0 to N) POLIN(I)*P(I,X)
  4044. C            This array should be declared to have at least N+1 elements
  4045. C            in the calling program.
  4046. C A0,A1,A2 = Estimated quadratic factors
  4047. C RECUR    = Name of the subroutine which defines the orthogonal
  4048. C            polynomials. See EXTEND for full description.
  4049. C IDIGIT   = Node convergence parameter (integer greater than 0).
  4050. C            An attempt is made to calculate the nodes to the maximum
  4051. C            accuracy possible by the machine precision available.
  4052. C            IDIGIT controls the assessment procedure to take account of
  4053. C            round-off errors and specifies the number of least signific
  4054. C            decimal digits that can be ignored (i.e. attributed
  4055. C            to round-off) in the computed relative error. Typical
  4056. C            value is 5.
  4057. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4058. C Output parameters:
  4059. C
  4060. C POLOUT   = Coefficients of the deflated polynomial of degree N-2 with
  4061. C            quadratic factor removed, i.e.
  4062. C                POLOUT = SUM(I=0 to N-2) POLOUT(I)*P(I,X)
  4063. C            This array should be declared to have at least N-1 elements
  4064. C            in the calling program.
  4065. C A0,A1,A2 = Calculated coefficients of the quadratic factor
  4066. C IFAIL    = 0 Quadratic factor found.
  4067. C          = 1 Convergence not achieved after 50 iterations.
  4068. C ERRVAL   = Mean value of the correction to the coefficients of
  4069. C            the quadratic factor. May be used as a measure of the
  4070. C            root accuracy when convergence is not achieved.
  4071. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4072.       PARAMETER (ZERO=0.0Q0,HALF=0.5Q0,ONE=1.0Q0,TEN=10.0Q0)
  4073.       IFAIL=0
  4074.       ITER=50
  4075.       ERRVAL=ZERO
  4076. C Special cases
  4077.       IF(N.EQ.1) THEN
  4078.         A0=-POLIN(0)
  4079.         A1=-POLIN(1)
  4080.         A2=ZERO
  4081.         RETURN
  4082.       END IF
  4083.       IF(N.EQ.2) THEN
  4084.         A0=-POLIN(0)
  4085.         A1=-POLIN(1)
  4086.         A2= POLIN(2)
  4087.         RETURN
  4088.       END IF
  4089. C Estimated ALPHA & BETA
  4090.       TOL=TEN**(-MAX(1,IDIGIT))
  4091.       ALPHA=A1/A2
  4092.       BETA=A0/A2
  4093. 10    ITER=ITER-1
  4094.       IF(ITER.LT.0) THEN
  4095.         IFAIL=1
  4096.         GOTO 20
  4097.       END IF
  4098.       CALL QFACT(N,POLIN,POLOUT,RECUR,ALPHA,BETA,A,B,AA,AB,BA,BB)
  4099.       SCALE=MAX(ABS(AB),ABS(BB))
  4100.       F1=AB/SCALE
  4101.       F2=BB/SCALE
  4102.       DELTA=(B*F1-A*F2)/(AA*F2-BA*F1)
  4103.       SCALE=MAX(ABS(BA),ABS(AA))
  4104.       F1=BA/SCALE
  4105.       F2=AA/SCALE
  4106.       EPS=(A*F1-B*F2)/(BB*F2-AB*F1)
  4107.       ALPHA=ALPHA+DELTA
  4108.       BETA=BETA+EPS
  4109. C Test for convergence
  4110. C Stop if correction is less than 1/TOL times the smallest machine
  4111. C relative error.
  4112.       IF(ABS(ALPHA)+TOL*ABS(DELTA).NE.ABS(ALPHA)
  4113.      *               .OR. ABS(BETA)+TOL*ABS(EPS).NE.ABS(BETA)) GOTO 10
  4114. C Final iteration to tidy up result
  4115.       CALL QFACT(N,POLIN,POLOUT,RECUR,ALPHA,BETA,A,B,AA,AB,BA,BB)
  4116.       SCALE=MAX(ABS(AB),ABS(BB))
  4117.       F1=AB/SCALE
  4118.       F2=BB/SCALE
  4119.       DELTA=(B*F1-A*F2)/(AA*F2-BA*F1)
  4120.       SCALE=MAX(ABS(BA),ABS(AA))
  4121.       F1=BA/SCALE
  4122.       F2=AA/SCALE
  4123.       EPS=(A*F1-B*F2)/(BB*F2-AB*F1)
  4124.       ALPHA=ALPHA+DELTA
  4125.       BETA=BETA+EPS
  4126. 20    A0=BETA
  4127.       A1=ALPHA
  4128.       A2=ONE
  4129.       ERRVAL=HALF*(ABS(EPS)+ABS(DELTA))
  4130.       RETURN
  4131.       END
  4132.       SUBROUTINE QFACT(N,GAMMA,DELTA,RECUR,ALPHA,BETA,A,B,AA,AB,BA,BB)
  4133.       IMPLICIT REAL*16 (A-H,O-Z)
  4134.       REAL*16 GAMMA(0:*),DELTA(0:*),ALPHA,BETA,A,B,AA,AB,BA,BB
  4135.       INTEGER N
  4136.       EXTERNAL RECUR
  4137. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4138. C FORTRAN-77 Version 2.2: March 1987
  4139. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4140. C Purpose:
  4141. C
  4142. C Divide the polynomial SUM(I=0 to N) GAMMA(I)*P(I,X)
  4143. C by the quadratic factor, P(2,X)-ALPHA*P(1,X)-BETA*P(0,X)
  4144. C giving the quotient SUM(I=0 to N-2) DELTA(I)*P(I,X)
  4145. C and remainder A*P(1,X)+B*P(0,X) where P(I,X) is the orthogonal
  4146. C polynomial of degree I defined by RECUR.
  4147. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4148. C Unless indicated otherwise the type of each variable is implied
  4149. C by the default FORTRAN-77 naming convention.
  4150. C
  4151. C Input parameters:
  4152. C
  4153. C N          = Degree of GAMMA
  4154. C GAMMA      = Polynomial to be divided by quadratic factor
  4155. C ALPHA,BETA = Coefficients of quadratic factor
  4156. C RECUR      = Name of the subroutine which defines the orthogonal
  4157. C              polynomials. See EXTEND for a full description.
  4158. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4159. C Output parameters:
  4160. C
  4161. C DELTA = Quotient polynomial of degreee N-2
  4162. C A,B   = Remainder coefficients
  4163. C AA    = Partial of A with respect to ALPHA
  4164. C AB    = Partial of A with respect to BETA
  4165. C BA    = Partial of B with respect to ALPHA
  4166. C BB    = Partial of B with respect to BETA
  4167. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4168.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  4169. C Initialise coefficients
  4170.       DNP2=ZERO
  4171.       DNP1=ZERO
  4172.       DN  =ZERO
  4173.       DNM1=ZERO
  4174. C Partial coefficients wrt ALPHA
  4175.       ADNP2=ZERO
  4176.       ADNP1=ZERO
  4177.       ADN  =ZERO
  4178.       ADNM1=ZERO
  4179. C Partial coefficients wrt BETA
  4180.       BDNP2=ZERO
  4181.       BDNP1=ZERO
  4182.       BDN  =ZERO
  4183.       BDNM1=ZERO
  4184. C
  4185. C Scaling parameters
  4186.       SN1=ONE
  4187.       SN2=ONE
  4188.       SN3=ONE
  4189.       SN4=ONE
  4190.       CALL RECUR(0,C0,D0,E0)
  4191.       CALL RECUR(1,C1,D1,E1)
  4192.       CALL RECUR(2,C2,D2,E2)
  4193.       CALL RECUR(3,C3,D3,E3)
  4194.       R0=-C0*E1/C1
  4195.       R1=-C0*E2/C2
  4196.       R2=-C0*E3/C3
  4197.       VM1=D0-C0*D1/C1
  4198.       VM2=D0-C0*D2/C2
  4199.       W0=-R1*E1
  4200.       W1=-C1*R2*E2/C2
  4201.       V1=D1*R1-C1*VM2*E2/C2-C1*R1*D1/C1
  4202.       K=N-2
  4203.       CALL RECUR(K+4,CK4,DK4,EK4)
  4204.       CALL RECUR(K+3,CK3,DK3,EK3)
  4205.       CALL RECUR(K+2,CK2,DK2,EK2)
  4206.       CALL RECUR(K+1,CK1,DK1,EK1)
  4207.       VLK4=C0/CK3
  4208.       VLK3=C0/CK2
  4209.       VLK2=C0/CK1
  4210.       RK3=-C0*EK4/CK4
  4211.       RK2=-C0*EK3/CK3
  4212.       VMK3=D0-DK3*VLK4
  4213.       VMK2=D0-DK2*VLK3
  4214. C Extract quadratic factor and find partial derivatives
  4215.       DO 100 K=N-2,0,-1
  4216.         CALL RECUR(K,CK,DK,EK)
  4217.         VLK1=C0/CK
  4218.         RK1=-C0*EK2/CK2
  4219.         VMK1=D0-DK1*VLK2
  4220.         SK2=C1*VLK1*VLK2/C0
  4221.         TK2=VLK2*(D1-C1*DK2/CK2)+C1*VMK1/CK1
  4222.         UK2=D1*VMK2+E1-C1*VLK3*EK3/CK3-C1*VMK2*DK2/CK2+C1*RK1/CK1
  4223.         VK2=D1*RK2-C1*VMK3*EK3/CK3-C1*RK2*DK2/CK2
  4224.         WK2=-C1*RK3*EK3/CK3
  4225.         CF1=(ALPHA*VLK2-TK2)/SN1
  4226.         CF2=(BETA+ALPHA*VMK2-UK2)/SN2
  4227.         CF3=(ALPHA*RK2-VK2)/SN3
  4228.         CF4=-WK2/SN4
  4229.         RS=GAMMA(K+2)
  4230. 40      D=RS+CF1*DNM1+CF2*DN+CF3*DNP1+CF4*DNP2
  4231.         DELTA(K)=D/SK2
  4232. 80      DA=VLK2*DNM1/SN1+VMK2*DN/SN2+RK2*DNP1/SN3
  4233.      *      + CF1*ADNM1+CF2*ADN+CF3*ADNP1+CF4*ADNP2
  4234.         DB=DN/SN2+CF1*BDNM1+CF2*BDN+CF3*BDNP1+CF4*BDNP2
  4235. C Recycle old values
  4236.         SN4=SN3
  4237.         SN3=SN2
  4238.         SN2=SN1
  4239.         SN1=SK2
  4240.         DNP2=DNP1
  4241.         DNP1=DN
  4242.         DN=DNM1
  4243.         DNM1=D
  4244.         ADNP2=ADNP1
  4245.         ADNP1=ADN
  4246.         ADN=ADNM1
  4247.         ADNM1=DA
  4248.         BDNP2=BDNP1
  4249.         BDNP1=BDN
  4250.         BDN=BDNM1
  4251.         BDNM1=DB
  4252.         CK4=CK3
  4253.         CK3=CK2
  4254.         CK2=CK1
  4255.         CK1=CK
  4256.         DK4=DK3
  4257.         DK3=DK2
  4258.         DK2=DK1
  4259.         DK1=DK
  4260.         EK4=EK3
  4261.         EK3=EK2
  4262.         EK2=EK1
  4263.         EK1=EK
  4264.         VLK4=VLK3
  4265.         VLK3=VLK2
  4266.         VLK2=VLK1
  4267.         RK3=RK2
  4268.         RK2=RK1
  4269.         VMK3=VMK2
  4270.         VMK2=VMK1
  4271. 100     CONTINUE
  4272.       CF1=ALPHA
  4273.       CF2=BETA+ALPHA*VM1-R1
  4274.       CF3=ALPHA*R1-V1
  4275.       CF4=-W1
  4276.       CF5=ALPHA*R0
  4277.       RS0=GAMMA(0)
  4278.       RS1=GAMMA(1)
  4279.       DNM1=DNM1/SN1
  4280.       DN=DN/SN2
  4281.       DNP1=DNP1/SN3
  4282.       DNP2=DNP2/SN4
  4283.       ADNM1=ADNM1/SN1
  4284.       ADN=ADN/SN2
  4285.       ADNP1=ADNP1/SN3
  4286.       ADNP2=ADNP2/SN4
  4287.       BDNM1=BDNM1/SN1
  4288.       BDN=BDN/SN2
  4289.       BDNP1=BDNP1/SN3
  4290.       BDNP2=BDNP2/SN4
  4291. C Remainder
  4292.       A=RS1+CF1*DNM1+CF2*DN+CF3*DNP1+CF4*DNP2
  4293.       B=RS0+BETA*DNM1+CF5*DN-W0*DNP1
  4294. C Partials
  4295.       AA=DNM1+VM1*DN+R1*DNP1+CF1*ADNM1+CF2*ADN+CF3*ADNP1+CF4*ADNP2
  4296.       AB=DN+CF1*BDNM1+CF2*BDN+CF3*BDNP1+CF4*BDNP2
  4297.       BA=R0*DN+BETA*ADNM1+CF5*ADN-W0*ADNP1
  4298.       BB=DNM1+BETA*BDNM1+CF5*BDN-W0*BDNP1
  4299.       RETURN
  4300.       END
  4301.       SUBROUTINE ROOTS(A0,A1,A2,ZREAL1,ZIMAG1,ZREAL2,ZIMAG2,RECUR,INFO)
  4302.       IMPLICIT REAL*16 (A-H,O-Z)
  4303.       REAL*16 A0,A1,A2,ZREAL1,ZIMAG1,ZREAL2,ZIMAG2
  4304.       INTEGER INFO
  4305.       EXTERNAL RECUR
  4306. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4307. C FORTRAN-77 Version 2.2: March 1987
  4308. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4309. C Purpose:
  4310. C
  4311. C Calculates the roots corresponding to the quadratic factor
  4312. C        A2*P(2,X)-A1*P(1,X)-A0*P(0,X)
  4313. C where P(I,X) is a general orthogonal polynomial of degree I
  4314. C defined by the recurrence calculated by subroutine RECUR.
  4315. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4316. C Unless indicated otherwise the type of each variable is implied
  4317. C by the default FORTRAN-77 naming convention.
  4318. C
  4319. C Input parameters:
  4320. C   A0,A1,A2 = Coefficients of quadratic factor
  4321. C   RECUR    = Name of the subroutine which defines the orthogonal
  4322. C              polynomials. See EXTEND for full description.
  4323. C
  4324. C Output parameters:
  4325. C   ZREAL1   = Real part of root 1
  4326. C   ZIMAG1   = Imaginary part of root 1
  4327. C   ZREAL2   = Real part of root 2
  4328. C   ZIMAG2   = Imaginary part of root 2
  4329. C   INFO     = 0 Two roots found
  4330. C            = 1 One root only (A2=0)
  4331. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4332.       PARAMETER (ZERO=0.0Q0,HALF=0.5Q0,FOUR=4.0Q0)
  4333.       INFO=0
  4334. C
  4335.       CALL RECUR(0,C0,D0,E0)
  4336.       IF(A2.EQ.ZERO) THEN
  4337.         ZREAL1=-(A0+A1*D0)/A1/C0
  4338.         ZREAL2=ZERO
  4339.         ZIMAG1=ZERO
  4340.         ZIMAG2=ZERO
  4341.         INFO=1
  4342.         RETURN
  4343.       END IF
  4344.       CALL RECUR(1,C1,D1,E1)
  4345.       AA=-C0*C1*A2
  4346.       BB=-A2*(C0*D1+D0*C1)+C0*A1
  4347.       CC=-D0*D1*A2-E1*A2+A0+A1*D0
  4348.       Z=BB*BB-FOUR*AA*CC
  4349.       ZR=SQRT(ABS(Z))
  4350.       IF(Z.GE.ZERO) THEN
  4351.         ZIMAG1=ZERO
  4352.         ZIMAG2=ZERO
  4353.         ZREAL1=HALF*(-BB-SIGN(ZR,BB))/AA
  4354.         ZREAL2=CC/AA/ZREAL1
  4355.       ELSE
  4356.         ZREAL1=-HALF*BB/AA
  4357.         ZREAL2=ZREAL1
  4358.         ZIMAG1=HALF*ZR/AA
  4359.         ZIMAG2=-ZIMAG1
  4360.       END IF
  4361.       END
  4362.       SUBROUTINE NEWTON(T,N,XNODE,RECUR,IDIGIT,DELTA,ERRVAL,IFAIL)
  4363.       IMPLICIT REAL*16 (A-H,O-Z)
  4364.       REAL*16 T(0:*),DELTA(0:*)
  4365.       REAL*16 XNODE,ERRVAL
  4366.       INTEGER N,IDIGIT
  4367.       EXTERNAL RECUR
  4368. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4369. C FORTRAN-77 Version 2.2: March 1987
  4370. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4371. C Purpose:
  4372. C
  4373. C Applies Newton's method to find a single root of the
  4374. C polynomial T expressed as:
  4375. C                  T =   SUM (I=0 to N) T(I)*P(I,X)
  4376. C where P(I,X) are the orthogonal polymonials whose recurrence
  4377. C relation is defined by RECUR.
  4378. C
  4379. C The value of T is found from the remainder when T is divided
  4380. C by (X-XNODE). The derivative (of the remainder) is
  4381. C calculated simultaneously. The deflated polynomial
  4382. C              DELTA = SUM (I=0 to N-1) DELTA(I)*P(I,X)
  4383. C is also computed.
  4384. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4385. C Unless indicated otherwise the type of each variable is implied
  4386. C by the default FORTRAN-77 naming convention.
  4387. C
  4388. C Input parameters:
  4389. C
  4390. C T      = Polynomial whose roots define the nodes of the quadrature rul
  4391. C          and expressed as:
  4392. C                  T =   SUM (I=0 to N) T(I)*P(I,X)
  4393. C          This array should be declared to have at least N+1 elements
  4394. C          in the calling program.
  4395. C N      = Degree of the expansion of T.
  4396. C XNODE  = Approximation to root
  4397. C RECUR  = Name of the subroutine which defines the orthogonal
  4398. C          polynomials. See EXTEND for a full description.
  4399. C IDIGIT = Node convergence paramter (integer greater than 0).
  4400. C          An attempt is made to calculate the nodes to the maximum
  4401. C          accuracy possible by the machine precision available.
  4402. C          IDIGIT controls the assessment procedure to take account of
  4403. C          round-off errors and specifies the number of least significan
  4404. C          decimal digits that can be ignored (i.e. attributed
  4405. C          to round-off) in the computed relative error. Typical
  4406. C          value is 5.
  4407. C
  4408. C Output parameters:
  4409. C
  4410. C XNODE  = Required root.
  4411. C DELTA  = Array holding the coefficients of the deflated polynomial
  4412. C          of degree N-1. This array should be declared to have at
  4413. C          least N elements in the calling program.
  4414. C ERRVAL = Value of the correction. May be used as a measure of the
  4415. C          root accuracy when convergence is not achieved.
  4416. C IFAIL  = 0, Convergence OK.
  4417. C        = 1, Unsatisfactory convergence after 50 iterations.
  4418. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4419.       PARAMETER (TEN=10.0Q0)
  4420. C
  4421.       ITER=50
  4422.       TOL=TEN**(-MAX(1,IDIGIT))
  4423. 10    ITER=ITER-1
  4424.       IF(ITER.LT.0) THEN
  4425.         IFAIL=1
  4426.         ERRVAL=ABS(EPS)
  4427.         RETURN
  4428.       END IF
  4429.       CALL LFACT(T,DELTA,N,XNODE,RECUR,R,DR)
  4430.       EPS=-R/DR
  4431.       XNODE=XNODE+EPS
  4432.       IF(ABS(XNODE)+TOL*ABS(EPS).NE.ABS(XNODE)) GOTO 10
  4433. C Final iteration
  4434.       CALL LFACT(T,DELTA,N,XNODE,RECUR,R,DR)
  4435.       EPS=-R/DR
  4436.       XNODE=XNODE+EPS
  4437.       IFAIL=0
  4438.       ERRVAL=ABS(EPS)
  4439. 40    RETURN
  4440.       END
  4441.       SUBROUTINE LFACT(GAMMA,DELTA,N,XNODE,RECUR,R,DR)
  4442.       IMPLICIT REAL*16 (A-H,O-Z)
  4443.       REAL*16 GAMMA(0:*),DELTA(0:*),XNODE,R,DR
  4444.       INTEGER N
  4445.       EXTERNAL RECUR
  4446. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4447. C FORTRAN-77 Version 2.2: March 1987
  4448. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4449. C Purpose:
  4450. C
  4451. C Remove the linear factor (X-XNODE) from the polynomial expansion
  4452. C             SUM(I=0 to N) GAMMA(I) P(I,X)
  4453. C to give the quotient,
  4454. C             SUM (I=0 to N-1) DELTA(I)*P(I,X).
  4455. C and the remainder and its derivative at XNODE.
  4456. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4457. C Input parameters:
  4458. C GAMMA  = Polynomial from which factor is to be removed
  4459. C          and expressed as:
  4460. C             GAMMA =   SUM (I=0 to N) GAMMA(I)*P(I,X)
  4461. C          This array should be declared to have at least N+1 elements
  4462. C          in the calling program.
  4463. C N      = Degree of GAMMA.
  4464. C XNODE  = Node to be removed.
  4465. C RECUR  = Name of the subroutine which defines the orthogonal
  4466. C          polynomials. See EXTEND for a full description.
  4467. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4468. C Output parameters:
  4469. C DELTA  = Quotient polynomial expressed as:
  4470. C                  DELTA =   SUM (I=0 to N-1) DELTA(I)*P(I,X)
  4471. C          This array should be declared to have at least N elements
  4472. C          in the calling program.
  4473. C R      = Remainder from division.
  4474. C DR     = Derivative of R with respect to XNODE.
  4475. C          (-R/DR is the Newton correction).
  4476. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4477.       PARAMETER (ZERO=0.0Q0)
  4478. C
  4479.       BK1=ZERO
  4480.       BK2=ZERO
  4481.       DBK1=ZERO
  4482.       DBK2=ZERO
  4483.       CALL RECUR(N,CK,DK,EK)
  4484.       CALL RECUR(N+1,CK1,DK1,EK1)
  4485.       DO 10 K=N,0,-1
  4486.         R=GAMMA(K)+(DK+XNODE*CK)*BK1+EK1*BK2
  4487.         DR=(DK+XNODE*CK)*DBK1+EK1*DBK2+CK*BK1
  4488.         BK2=BK1
  4489.         BK1=R
  4490.         DBK2=DBK1
  4491.         DBK1=DR
  4492.         IF(K.NE.0) THEN
  4493.           CALL RECUR(K-1,CKM1,DKM1,EKM1)
  4494.           DELTA(K-1)=R*CKM1
  4495.         END IF
  4496.         EK1=EK
  4497.         CK=CKM1
  4498.         DK=DKM1
  4499.         EK=EKM1
  4500. 10      CONTINUE
  4501.       RETURN
  4502.       END
  4503.       SUBROUTINE EPROD(N,J,COEFF,WORK,LW,RECUR,IFAIL)
  4504.       IMPLICIT REAL*16 (A-H,O-Z)
  4505.       REAL*16 COEFF(*),WORK(LW,2)
  4506.       INTEGER N,J,LW,IFAIL
  4507.       EXTERNAL RECUR
  4508. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4509. C FORTRAN-77 Version 2.2: March 1987
  4510. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4511. C Purpose:
  4512. C
  4513. C Calculates the expansion of a product of two orthogonal polynomials
  4514. C
  4515. C     P(N,X)*P(J,X) = SUM (I=N-J to N+J ) COEFF(I)*P(I,X)
  4516. C
  4517. C where J must not exceed N. The orthogonal polynomials are defined
  4518. C by the recurrence relation calculated by the external
  4519. C subroutine RECUR.
  4520. C
  4521. C For proper initialisation the subroutine must first be called
  4522. C with J=0 and the required value of N. Subsequent calls must be in
  4523. C the order J=1,2,,,,,N with the appropriate expansion being
  4524. C generated from previous values and returned in COEFF(*). The
  4525. C coefficients of P(N-J,X),...., P(N+J,X) are stored in the array
  4526. C COEFF(1),...,COEFF(2*J+1).
  4527. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4528. C Unless indicated otherwise the type of each variable is implied
  4529. C by the default FORTRAN-77 naming convention.
  4530. C
  4531. C Input parameters:
  4532. C
  4533. C N     = Highest polynomial degree. Note that after the initial
  4534. C         call with J=0 the value of N in this argument is ignored.
  4535. C J     = Current product of P(J,X) with P(N,X) to be calculated.
  4536. C         Note that the subroutine must be first called with J=0 and
  4537. C         the required largest N. Subsequent calls must be
  4538. C         in the order J=1,2,..,N.
  4539. C WORK  = Matrix work area which must be declared in the calling
  4540. C         program to have dimensions at least (2*J+1) by 2.
  4541. C         The contents of this work area must not be altered between
  4542. C         calls by the calling program.
  4543. C LW    = Leading dimension of WORK in the calling program
  4544. C RECUR = Name of the subroutine which defines the orthogonal
  4545. C         polynomials. See EXTEND for a full description.
  4546. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4547. C Output parameters:
  4548. C
  4549. C    COEFF = Array holding the calculated coefficients.
  4550. C            This array should be declared to have at least 2*J+1 elemen
  4551. C            in the calling program.
  4552. C    IFAIL = 0 Result OK
  4553. C          = 1 J exceeds N
  4554. C          = 2 J has not been called sequentially
  4555. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
  4556.       INTEGER S,SS,IX(2)
  4557.       SAVE IX,SS,LAST
  4558.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  4559. C
  4560.       IFAIL=0
  4561. C Initialise
  4562.       IF(J.EQ.0) THEN
  4563.         IX(1)=1
  4564.         IX(2)=2
  4565.         COEFF(1)=ONE
  4566.         WORK(1,2)=ONE
  4567.         LAST=0
  4568.         SS=N
  4569.         RETURN
  4570.       END IF
  4571.       S=SS
  4572. C Check that J does not exceed S value
  4573.       IF(S.LT.J) THEN
  4574.         IFAIL=1
  4575.         RETURN
  4576.       END IF
  4577. C Check that J is used sequentially
  4578.       IF(LAST.NE.J-1) THEN
  4579.         IFAIL=2
  4580.         RETURN
  4581.       END IF
  4582.       LAST=J
  4583.       J2=J+J
  4584.       CALL RECUR(J-1,CJ1,DJ1,EJ1)
  4585.       IF(J.EQ.1) THEN
  4586.         DO 20 I=1,J2+1
  4587.           COEFF(I)=ZERO
  4588. 20        CONTINUE
  4589.       ELSE
  4590.         DO 25 I=1,J2-3
  4591.           COEFF(I+2)=WORK(I,IX(1))*EJ1
  4592. 25        CONTINUE
  4593.         COEFF(1)   =ZERO
  4594.         COEFF(2)   =ZERO
  4595.         COEFF(J2)  =ZERO
  4596.         COEFF(J2+1)=ZERO
  4597.       END IF
  4598.       IBOT=S-J+1
  4599.       ITOP=S+J-1
  4600.       DO 30 II=IBOT,ITOP
  4601.         I=II-IBOT+1
  4602.         CALL RECUR(II,CI,DI,EI)
  4603.         COEFF(I+2)=COEFF(I+2)+(WORK(I,IX(2))/CI)*CJ1
  4604.         COEFF(I+1)=COEFF(I+1)+WORK(I,IX(2))*(DJ1-(CJ1/CI)*DI)
  4605.         COEFF(I)=COEFF(I)-(WORK(I,IX(2))/CI)*CJ1*EI
  4606. 30      CONTINUE
  4607.       II=IX(1)
  4608.       IX(1)=IX(2)
  4609.       IX(2)=II
  4610.       DO 35 I=1,J2+1
  4611.         WORK(I,IX(2))=COEFF(I)
  4612. 35      CONTINUE
  4613.       RETURN
  4614.       END
  4615.       SUBROUTINE GEFA77(A,LDA,N,IPVT,INFO)
  4616.       INTEGER LDA,N,IPVT(*),INFO
  4617.       REAL*16 A(LDA,*)
  4618. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4619. C This is an FORTRAN-77 adaption of LINPACK routine DGEFA
  4620. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4621. C     GEFA77 FACTORS A MATRIX BY GAUSSIAN ELIMINATION.
  4622. C
  4623. C     ON ENTRY
  4624. C
  4625. C        A       THE MATRIX TO BE FACTORED.
  4626. C
  4627. C        LDA     INTEGER
  4628. C                THE LEADING DIMENSION OF THE ARRAY  A .
  4629. C
  4630. C        N       INTEGER
  4631. C                THE ORDER OF THE MATRIX  A .
  4632. C
  4633. C     ON RETURN
  4634. C
  4635. C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
  4636. C                WHICH WERE USED TO OBTAIN IT.
  4637. C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
  4638. C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
  4639. C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
  4640. C
  4641. C        IPVT    INTEGER(N)
  4642. C                AN INTEGER VECTOR OF PIVOT INDICES.
  4643. C
  4644. C        INFO    INTEGER
  4645. C                = 0  NORMAL VALUE.
  4646. C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
  4647. C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
  4648. C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
  4649. C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
  4650. C                     INDICATION OF SINGULARITY.
  4651. C
  4652. C     SUBROUTINES AND FUNCTIONS
  4653. C
  4654. C     BLAS subroutines: DAXPY,DSCAL,IDAMAX
  4655. C     These have been renamed DAXPY7,DSCAL7,IDAMX7
  4656. C
  4657. C     INTERNAL VARIABLES
  4658. C
  4659.       REAL*16 T
  4660.       REAL*16 ZERO,ONE
  4661.       INTEGER IDAMX7,J,K,KP1,L,NM1
  4662.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  4663. C
  4664. C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
  4665. C
  4666.       INFO = 0
  4667.       NM1 = N - 1
  4668.       IF (NM1 .LT. 1) GO TO 70
  4669.       DO 60 K = 1, NM1
  4670.          KP1 = K + 1
  4671. C
  4672. C        FIND L = PIVOT INDEX
  4673. C
  4674.          L = IDAMX7(N-K+1,A(K,K),1) + K - 1
  4675.          IPVT(K) = L
  4676. C
  4677. C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
  4678.          IF (A(L,K) .EQ. ZERO) GO TO 40
  4679. C
  4680. C           INTERCHANGE IF NECESSARY
  4681. C
  4682.             IF (L .EQ. K) GO TO 10
  4683.                T = A(L,K)
  4684.                A(L,K) = A(K,K)
  4685.                A(K,K) = T
  4686.    10       CONTINUE
  4687. C
  4688. C           COMPUTE MULTIPLIERS
  4689. C
  4690.             T = -ONE/A(K,K)
  4691.             CALL DSCAL7(N-K,T,A(K+1,K),1)
  4692. C
  4693. C           ROW ELIMINATION WITH COLUMN INDEXING
  4694. C
  4695.             DO 30 J = KP1, N
  4696.                T = A(L,J)
  4697.                IF (L .EQ. K) GO TO 20
  4698.                   A(L,J) = A(K,J)
  4699.                   A(K,J) = T
  4700.    20          CONTINUE
  4701.                CALL DAXPY7(N-K,T,A(K+1,K),1,A(K+1,J),1)
  4702.    30       CONTINUE
  4703.          GO TO 50
  4704.    40    CONTINUE
  4705.             INFO = K
  4706.    50    CONTINUE
  4707.    60 CONTINUE
  4708.    70 CONTINUE
  4709.       IPVT(N) = N
  4710.       IF (A(N,N) .EQ. ZERO) INFO = N
  4711.       RETURN
  4712.       END
  4713.       SUBROUTINE GESL77(A,LDA,N,IPVT,B,JOB)
  4714.       INTEGER LDA,N,IPVT(*),JOB
  4715.       REAL*16 A(LDA,*),B(*)
  4716. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4717. C This is an FORTRAN-77 adaption of LINPACK routine DGESL
  4718. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4719. C     GESL77 SOLVES THE SYSTEM
  4720. C     A * X = B  OR  TRANS(A) * X = B
  4721. C     USING THE FACTORS COMPUTED BY GEFA77.
  4722. C
  4723. C     ON ENTRY
  4724. C
  4725. C        A       THE OUTPUT FROM GEFA77.
  4726. C
  4727. C        LDA     INTEGER
  4728. C                THE LEADING DIMENSION OF THE ARRAY  A .
  4729. C
  4730. C        N       INTEGER
  4731. C                THE ORDER OF THE MATRIX  A .
  4732. C
  4733. C        IPVT    INTEGER(N)
  4734. C                THE PIVOT VECTOR FROM GEFA77.
  4735. C
  4736. C        B       DIMENSION (N)
  4737. C                THE RIGHT HAND SIDE VECTOR.
  4738. C
  4739. C        JOB     INTEGER
  4740. C                = 0         TO SOLVE  A*X = B ,
  4741. C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
  4742. C                            TRANS(A)  IS THE TRANSPOSE.
  4743. C
  4744. C     ON RETURN
  4745. C
  4746. C        B       THE SOLUTION VECTOR  X .
  4747. C
  4748. C     ERROR CONDITION
  4749. C
  4750. C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
  4751. C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
  4752. C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
  4753. C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
  4754. C        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0
  4755. C        OR DGEFA HAS SET INFO .EQ. 0 .
  4756. C
  4757. C     SUBROUTINES AND FUNCTIONS
  4758. C
  4759. C     BLAS subroutines: DAXPY,DDOT
  4760. C     These have been renamed: DAXPY7,DDOT7
  4761. C     INTERNAL VARIABLES
  4762. C
  4763.       INTEGER K,KB,L,NM1
  4764.       REAL*16 DDOT7,T
  4765.       REAL*16 ZERO,ONE
  4766.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  4767. C
  4768.       NM1 = N - 1
  4769.       IF (JOB .NE. 0) GO TO 50
  4770. C
  4771. C        JOB = 0 , SOLVE  A * X = B
  4772. C        FIRST SOLVE  L*Y = B
  4773. C
  4774.          IF (NM1 .LT. 1) GO TO 30
  4775.          DO 20 K = 1, NM1
  4776.             L = IPVT(K)
  4777.             T = B(L)
  4778.             IF (L .EQ. K) GO TO 10
  4779.                B(L) = B(K)
  4780.                B(K) = T
  4781.    10       CONTINUE
  4782.             CALL DAXPY7(N-K,T,A(K+1,K),1,B(K+1),1)
  4783.    20    CONTINUE
  4784.    30    CONTINUE
  4785. C
  4786. C        NOW SOLVE  U*X = Y
  4787. C
  4788.          DO 40 KB = 1, N
  4789.             K = N + 1 - KB
  4790.             B(K) = B(K)/A(K,K)
  4791.             T = -B(K)
  4792.             CALL DAXPY7(K-1,T,A(1,K),1,B(1),1)
  4793.    40    CONTINUE
  4794.       GO TO 100
  4795.    50 CONTINUE
  4796. C
  4797. C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
  4798. C        FIRST SOLVE  TRANS(U)*Y = B
  4799. C
  4800.          DO 60 K = 1, N
  4801.             T = DDOT7(K-1,A(1,K),1,B(1),1)
  4802.             B(K) = (B(K) - T)/A(K,K)
  4803.    60    CONTINUE
  4804. C
  4805. C        NOW SOLVE TRANS(L)*X = Y
  4806. C
  4807.          IF (NM1 .LT. 1) GO TO 90
  4808.          DO 80 KB = 1, NM1
  4809.             K = N - KB
  4810.             B(K) = B(K) + DDOT7(N-K,A(K+1,K),1,B(K+1),1)
  4811.             L = IPVT(K)
  4812.             IF (L .EQ. K) GO TO 70
  4813.                T = B(L)
  4814.                B(L) = B(K)
  4815.                B(K) = T
  4816.    70       CONTINUE
  4817.    80    CONTINUE
  4818.    90    CONTINUE
  4819.   100 CONTINUE
  4820.       RETURN
  4821.       END
  4822.       SUBROUTINE  DSCAL7(N,DA,DX,INCX)
  4823. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4824. C This is an FORTRAN-77 adaption of BLAS routine DSCAL
  4825. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4826. C     SCALES A VECTOR BY A CONSTANT.
  4827. C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
  4828. C
  4829.       REAL*16 DA,DX(*)
  4830.       REAL*16 ZERO,ONE
  4831.       INTEGER I,INCX,M,MP1,N,NINCX
  4832.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  4833. C
  4834.       IF(N.LE.0)RETURN
  4835.       IF(INCX.EQ.1)GO TO 20
  4836. C
  4837. C        CODE FOR INCREMENT NOT EQUAL TO 1
  4838. C
  4839.       NINCX = N*INCX
  4840.       DO 10 I = 1,NINCX,INCX
  4841.         DX(I) = DA*DX(I)
  4842.    10 CONTINUE
  4843.       RETURN
  4844. C
  4845. C        CODE FOR INCREMENT EQUAL TO 1
  4846. C
  4847. C
  4848. C        CLEAN-UP LOOP
  4849. C
  4850.    20 M = MOD(N,5)
  4851.       IF( M .EQ. 0 ) GO TO 40
  4852.       DO 30 I = 1,M
  4853.         DX(I) = DA*DX(I)
  4854.    30 CONTINUE
  4855.       IF( N .LT. 5 ) RETURN
  4856.    40 MP1 = M + 1
  4857.       DO 50 I = MP1,N,5
  4858.         DX(I) = DA*DX(I)
  4859.         DX(I + 1) = DA*DX(I + 1)
  4860.         DX(I + 2) = DA*DX(I + 2)
  4861.         DX(I + 3) = DA*DX(I + 3)
  4862.         DX(I + 4) = DA*DX(I + 4)
  4863.    50 CONTINUE
  4864.       RETURN
  4865.       END
  4866.       INTEGER FUNCTION IDAMX7(N,DX,INCX)
  4867. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4868. C This is an FORTRAN-77 adaption of BLAS routine IDAMAX
  4869. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4870. C
  4871. C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
  4872. C
  4873.       REAL*16 DX(*),DMAX
  4874.       INTEGER I,INCX,IX,N
  4875. C
  4876.       IDAMX7 = 0
  4877.       IF( N .LT. 1 ) RETURN
  4878.       IDAMX7 = 1
  4879.       IF(N.EQ.1)RETURN
  4880.       IF(INCX.EQ.1)GO TO 20
  4881. C
  4882. C        CODE FOR INCREMENT NOT EQUAL TO 1
  4883. C
  4884.       IX = 1
  4885.       DMAX = ABS(DX(1))
  4886.       IX = IX + INCX
  4887.       DO 10 I = 2,N
  4888.          IF(ABS(DX(IX)).LE.DMAX) GO TO 5
  4889.          IDAMX7 = I
  4890.          DMAX = ABS(DX(IX))
  4891.     5    IX = IX + INCX
  4892.    10 CONTINUE
  4893.       RETURN
  4894. C
  4895. C        CODE FOR INCREMENT EQUAL TO 1
  4896. C
  4897.    20 DMAX = ABS(DX(1))
  4898.       DO 30 I = 2,N
  4899.          IF(ABS(DX(I)).LE.DMAX) GO TO 30
  4900.          IDAMX7 = I
  4901.          DMAX = ABS(DX(I))
  4902.    30 CONTINUE
  4903.       RETURN
  4904.       END
  4905.       SUBROUTINE DAXPY7(N,DA,DX,INCX,DY,INCY)
  4906. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4907. C This is an FORTRAN-77 adaption of BLAS routine DAXPY
  4908. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4909. C
  4910. C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
  4911. C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
  4912. C
  4913.       REAL*16 DX(*),DY(*),DA
  4914.       INTEGER I,INCX,INCY,IXIY,M,MP1,N
  4915.       REAL*16 ZERO,ONE
  4916.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  4917. C
  4918.       IF(N.LE.0)RETURN
  4919.       IF (DA .EQ. ZERO) RETURN
  4920.       IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
  4921. C
  4922. C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
  4923. C          NOT EQUAL TO 1
  4924. C
  4925.       IX = 1
  4926.       IY = 1
  4927.       IF(INCX.LT.0)IX = (-N+1)*INCX + 1
  4928.       IF(INCY.LT.0)IY = (-N+1)*INCY + 1
  4929.       DO 10 I = 1,N
  4930.         DY(IY) = DY(IY) + DA*DX(IX)
  4931.         IX = IX + INCX
  4932.         IY = IY + INCY
  4933.    10 CONTINUE
  4934.       RETURN
  4935. C
  4936. C        CODE FOR BOTH INCREMENTS EQUAL TO 1
  4937. C
  4938. C        CLEAN-UP LOOP
  4939. C
  4940.    20 M = MOD(N,4)
  4941.       IF( M .EQ. 0 ) GO TO 40
  4942.       DO 30 I = 1,M
  4943.         DY(I) = DY(I) + DA*DX(I)
  4944.    30 CONTINUE
  4945.       IF( N .LT. 4 ) RETURN
  4946.    40 MP1 = M + 1
  4947.       DO 50 I = MP1,N,4
  4948.         DY(I) = DY(I) + DA*DX(I)
  4949.         DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
  4950.         DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
  4951.         DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
  4952.    50 CONTINUE
  4953.       RETURN
  4954.       END
  4955.       REAL*16 FUNCTION DDOT7(N,DX,INCX,DY,INCY)
  4956. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4957. C This is an FORTRAN-77 adaption of BLAS routine DDOT
  4958. C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
  4959. C
  4960. C     FORMS THE DOT PRODUCT OF TWO VECTORS.
  4961. C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
  4962. C
  4963.       REAL*16 DX(*),DY(*),DTEMP
  4964.       INTEGER I,INCX,INCY,IX,IY,M,MP1,N
  4965.       REAL*16 ZERO,ONE
  4966.       PARAMETER (ZERO=0.0Q0,ONE=1.0Q0)
  4967. C
  4968.       DDOT7 = ZERO
  4969.       DTEMP = ZERO
  4970.       IF(N.LE.0)RETURN
  4971.       IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
  4972. C
  4973. C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
  4974. C          NOT EQUAL TO 1
  4975. C
  4976.       IX = 1
  4977.       IY = 1
  4978.       IF(INCX.LT.0)IX = (-N+1)*INCX + 1
  4979.       IF(INCY.LT.0)IY = (-N+1)*INCY + 1
  4980.       DO 10 I = 1,N
  4981.         DTEMP = DTEMP + DX(IX)*DY(IY)
  4982.         IX = IX + INCX
  4983.         IY = IY + INCY
  4984.    10 CONTINUE
  4985.       DDOT7 = DTEMP
  4986.       RETURN
  4987. C
  4988. C        CODE FOR BOTH INCREMENTS EQUAL TO 1
  4989. C
  4990. C
  4991. C        CLEAN-UP LOOP
  4992. C
  4993.    20 M = MOD(N,5)
  4994.       IF( M .EQ. 0 ) GO TO 40
  4995.       DO 30 I = 1,M
  4996.         DTEMP = DTEMP + DX(I)*DY(I)
  4997.    30 CONTINUE
  4998.       IF( N .LT. 5 ) GO TO 60
  4999.    40 MP1 = M + 1
  5000.       DO 50 I = MP1,N,5
  5001.         DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
  5002.      *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
  5003.    50 CONTINUE
  5004.    60 DDOT7 = DTEMP
  5005.       RETURN
  5006.       END
  5007. This disc contains the files:
  5008.  
  5009. DEXT22.FOR       Double precision version of the package.
  5010.  
  5011. MEXT22.FOR       Quadruple precision version for VAX/VMS.
  5012.  
  5013. SAMPLE.LOG       Output of DEXT22.FOR run under VAX/VMS with the
  5014.                  input paramanters set to:
  5015.                    Case            No. of rules
  5016.                      1                 3           Gauss-Legendre
  5017.                      2                 3           Gauss-Lobatto
  5018.                      3                 3           Gauss-Radau
  5019.                      4                 2           Gauss-Laguerre
  5020.                      5                 2           Gauss-Hermite
  5021.                      6                 3           Gauss-Jacobi
  5022.  
  5023.  
  5024. Log of output from DEXT22 for:
  5025.  
  5026. =========================================================
  5027.         Case            No. of rules
  5028.           1                 3           Gauss-Legendre
  5029.           2                 3           Gauss-Lobatto
  5030.           3                 3           Gauss-Radau
  5031.           4                 2           Gauss-Laguerre
  5032.           5                 2           Gauss-Hermite
  5033.           6                 3           Gauss-Jacobi
  5034. =========================================================
  5035.  
  5036. RUN DEXT22
  5037.  
  5038. Case ?:
  5039. 1
  5040.  
  5041. No. of rules?:
  5042. 3
  5043.  
  5044. Gauss-Legendre 3-point extension
  5045. Iteration           1
  5046. Coefficients of expansion whose roots are the new nodes:
  5047.   0.0000000000000000D+00*P(  0,X)
  5048.   0.0000000000000000D+00*P(  1,X)
  5049.   0.0000000000000000D+00*P(  2,X)
  5050.   0.1000000000000000D+01*P(  3,X)
  5051. New nodes
  5052.                     REAL                IMAGINARY FLAG       ERR
  5053.   0.0000000000000000D+00   0.0000000000000000D+00    0   0.0D+00
  5054.   0.7745966692414834D+00   0.0000000000000000D+00    0   0.0D+00
  5055.  -0.7745966692414834D+00   0.0000000000000000D+00    0   0.0D+00
  5056. New full extended expansion
  5057.   0.1000000000000000D+01*P(  3,X)/HI
  5058. Complete extended rule: STEP= 1  POINTS=  3  IFLAG=0  NODES ADDED=  3
  5059.  No.                     NODE                   WEIGHT
  5060.    1   0.7745966692414834D+00   0.5555555555555555D+00
  5061.    2   0.0000000000000000D+00   0.8888888888888889D+00
  5062. TEST( 0)=   0.1000000000000000D+01
  5063. TEST( 1)=   0.9999999999999999D+00
  5064. TEST( 2)=   0.1000000000000000D+01
  5065. Iteration           2
  5066. Coefficients of expansion whose roots are the new nodes:
  5067.   0.1571268237934905D-01*P(  0,X)
  5068.   0.0000000000000000D+00*P(  1,X)
  5069.  -0.7407407407407407D+00*P(  2,X)
  5070.   0.0000000000000000D+00*P(  3,X)
  5071.   0.1000000000000000D+01*P(  4,X)
  5072. New nodes
  5073.                     REAL                IMAGINARY FLAG       ERR
  5074.   0.4342437493468026D+00   0.0000000000000000D+00    0   0.0D+00
  5075.  -0.4342437493468026D+00   0.0000000000000000D+00    0   0.0D+00
  5076.   0.9604912687080203D+00   0.0000000000000000D+00    0   0.0D+00
  5077.  -0.9604912687080203D+00   0.0000000000000000D+00    0   0.0D+00
  5078. New full extended expansion
  5079.   0.0000000000000000D+00*P(  4,X)/HI
  5080.  -0.4444444444444444D+00*P(  5,X)/HI
  5081.   0.0000000000000000D+00*P(  6,X)/HI
  5082.   0.1000000000000000D+01*P(  7,X)/HI
  5083. Complete extended rule: STEP= 2  POINTS=  7  IFLAG=0  NODES ADDED=  4
  5084.  No.                     NODE                   WEIGHT
  5085.    1   0.9604912687080203D+00   0.1046562260264673D+00
  5086.    2   0.7745966692414834D+00   0.2684880898683335D+00
  5087.    3   0.4342437493468026D+00   0.4013974147759622D+00
  5088.    4   0.0000000000000000D+00   0.4509165386584741D+00
  5089. TEST( 0)=   0.1000000000000000D+01
  5090. TEST( 1)=   0.1000000000000000D+01
  5091. TEST( 2)=   0.1000000000000000D+01
  5092. TEST( 3)=   0.1000000000000000D+01
  5093. TEST( 4)=   0.1000000000000000D+01
  5094. Iteration           3
  5095. Coefficients of expansion whose roots are the new nodes:
  5096.   0.5772349298067298D-03*P(  0,X)
  5097.   0.0000000000000000D+00*P(  1,X)
  5098.   0.1407910917434097D-02*P(  2,X)
  5099.   0.0000000000000000D+00*P(  3,X)
  5100.   0.2790650691523971D+00*P(  4,X)
  5101.   0.0000000000000000D+00*P(  5,X)
  5102.  -0.1205049839843540D+01*P(  6,X)
  5103.   0.0000000000000000D+00*P(  7,X)
  5104.   0.1000000000000000D+01*P(  8,X)
  5105. New nodes
  5106.                     REAL                IMAGINARY FLAG       ERR
  5107.   0.2233866864289669D+00   0.0000000000000000D+00    0   0.2D-17
  5108.  -0.2233866864289669D+00   0.0000000000000000D+00    0   0.2D-17
  5109.   0.6211029467372264D+00   0.0000000000000000D+00    0   0.1D-17
  5110.  -0.6211029467372264D+00   0.0000000000000000D+00    0   0.1D-17
  5111.   0.8884592328722570D+00   0.0000000000000000D+00    0   0.3D-17
  5112.  -0.8884592328722570D+00   0.0000000000000000D+00    0   0.3D-17
  5113.   0.9938319632127550D+00   0.0000000000000000D+00    0   0.1D-17
  5114.  -0.9938319632127550D+00   0.0000000000000000D+00    0   0.1D-17
  5115. New full extended expansion
  5116.   0.0000000000000000D+00*P(  8,X)/HI
  5117.  -0.2896464423067150D-01*P(  9,X)/HI
  5118.   0.0000000000000000D+00*P( 10,X)/HI
  5119.   0.3461310330856246D+00*P( 11,X)/HI
  5120.   0.0000000000000000D+00*P( 12,X)/HI
  5121.  -0.1000000000000000D+01*P( 13,X)/HI
  5122.   0.0000000000000000D+00*P( 14,X)/HI
  5123.   0.7705426896934803D+00*P( 15,X)/HI
  5124. Complete extended rule: STEP= 3  POINTS= 15  IFLAG=0  NODES ADDED=  8
  5125.  No.                     NODE                   WEIGHT
  5126.    1   0.9938319632127550D+00   0.1700171962994028D-01
  5127.    2   0.9604912687080203D+00   0.5160328299707982D-01
  5128.    3   0.8884592328722570D+00   0.9292719531512452D-01
  5129.    4   0.7745966692414834D+00   0.1344152552437843D+00
  5130.    5   0.6211029467372264D+00   0.1715119091363914D+00
  5131.    6   0.4342437493468026D+00   0.2006285293769890D+00
  5132.    7   0.2233866864289669D+00   0.2191568584015875D+00
  5133.    8   0.0000000000000000D+00   0.2255104997982067D+00
  5134. TEST( 0)=   0.1000000000000000D+01
  5135. TEST( 1)=   0.1000000000000000D+01
  5136. TEST( 2)=   0.1000000000000000D+01
  5137. TEST( 3)=   0.1000000000000000D+01
  5138. TEST( 4)=   0.1000000000000000D+01
  5139.  
  5140. Case ?:
  5141. 2
  5142.  
  5143. No. of rules?:
  5144. 3
  5145.  
  5146. Lobatto 2-point extension
  5147. Iteration           1
  5148. Coefficients of expansion whose roots are the new nodes:
  5149.   0.0000000000000000D+00*P(  0,X)
  5150.   0.1000000000000000D+01*P(  1,X)
  5151. New nodes
  5152.                     REAL                IMAGINARY FLAG       ERR
  5153.   0.0000000000000000D+00   0.0000000000000000D+00    0   0.0D+00
  5154. New full extended expansion
  5155.  -0.1000000000000000D+01*P(  1,X)/HI
  5156.   0.0000000000000000D+00*P(  2,X)/HI
  5157.   0.4285714285714286D+00*P(  3,X)/HI
  5158. Complete extended rule: STEP= 1  POINTS=  3  IFLAG=0  NODES ADDED=  1
  5159.  No.                     NODE                   WEIGHT
  5160.    1   0.1000000000000000D+01   0.3333333333333333D+00
  5161.    2   0.0000000000000000D+00   0.1333333333333333D+01
  5162. TEST( 0)=   0.1000000000000000D+01
  5163. TEST( 1)=   0.1000000000000000D+01
  5164. Iteration           2
  5165. Coefficients of expansion whose roots are the new nodes:
  5166.  -0.1428571428571429D+00*P(  0,X)
  5167.   0.0000000000000000D+00*P(  1,X)
  5168.   0.1000000000000000D+01*P(  2,X)
  5169. New nodes
  5170.                     REAL                IMAGINARY FLAG       ERR
  5171.   0.6546536707079772D+00   0.0000000000000000D+00    0   0.0D+00
  5172.  -0.6546536707079771D+00   0.0000000000000000D+00    0   0.0D+00
  5173. New full extended expansion
  5174.   0.0000000000000000D+00*P(  2,X)/HI
  5175.  -0.1000000000000000D+01*P(  3,X)/HI
  5176.   0.0000000000000000D+00*P(  4,X)/HI
  5177.   0.6363636363636364D+00*P(  5,X)/HI
  5178. Complete extended rule: STEP= 2  POINTS=  5  IFLAG=0  NODES ADDED=  2
  5179.  No.                     NODE                   WEIGHT
  5180.    1   0.1000000000000000D+01   0.1000000000000000D+00
  5181.    2   0.6546536707079772D+00   0.5444444444444445D+00
  5182.    3   0.0000000000000000D+00   0.7111111111111111D+00
  5183. TEST( 0)=   0.1000000000000000D+01
  5184. TEST( 1)=   0.1000000000000000D+01
  5185. TEST( 2)=   0.1000000000000000D+01
  5186. TEST( 3)=   0.1000000000000000D+01
  5187. Iteration           3
  5188. Coefficients of expansion whose roots are the new nodes:
  5189.  -0.4746768383132019D-01*P(  0,X)
  5190.   0.0000000000000000D+00*P(  1,X)
  5191.  -0.1515151515151515D+00*P(  2,X)
  5192.   0.0000000000000000D+00*P(  3,X)
  5193.   0.1000000000000000D+01*P(  4,X)
  5194. New nodes
  5195.                     REAL                IMAGINARY FLAG       ERR
  5196.   0.3409822659109930D+00   0.0000000000000000D+00    0   0.0D+00
  5197.  -0.3409822659109930D+00   0.0000000000000000D+00    0   0.0D+00
  5198.   0.8904055275126688D+00   0.0000000000000000D+00    0   0.2D-17
  5199.  -0.8904055275126688D+00   0.0000000000000000D+00    0   0.2D-17
  5200. New full extended expansion
  5201.   0.0000000000000000D+00*P(  4,X)/HI
  5202.  -0.3813459268004723D+00*P(  5,X)/HI
  5203.   0.0000000000000000D+00*P(  6,X)/HI
  5204.  -0.9870129870129869D+00*P(  7,X)/HI
  5205.   0.0000000000000000D+00*P(  8,X)/HI
  5206.   0.1000000000000000D+01*P(  9,X)/HI
  5207. Complete extended rule: STEP= 3  POINTS=  9  IFLAG=0  NODES ADDED=  4
  5208.  No.                     NODE                   WEIGHT
  5209.    1   0.1000000000000000D+01   0.3064373897707232D-01
  5210.    2   0.8904055275126688D+00   0.1792626995532074D+00
  5211.    3   0.6546536707079772D+00   0.2839787780481211D+00
  5212.    4   0.3409822659109930D+00   0.3342337398164177D+00
  5213.    5   0.0000000000000000D+00   0.3437620872103631D+00
  5214. TEST( 0)=   0.1000000000000000D+01
  5215. TEST( 1)=   0.1000000000000000D+01
  5216. TEST( 2)=   0.1000000000000000D+01
  5217. TEST( 3)=   0.1000000000000000D+01
  5218. TEST( 4)=   0.1000000000000000D+01
  5219.  
  5220. Case ?:
  5221. 3
  5222.  
  5223. No. of rules?:
  5224. 3
  5225.  
  5226. Radau 6-point extension
  5227. Iteration           1
  5228. Coefficients of expansion whose roots are the new nodes:
  5229.  -0.9090909090909092D-01*P(  0,X)
  5230.   0.2727272727272728D+00*P(  1,X)
  5231.  -0.4545454545454546D+00*P(  2,X)
  5232.   0.6363636363636364D+00*P(  3,X)
  5233.  -0.8181818181818182D+00*P(  4,X)
  5234.   0.1000000000000000D+01*P(  5,X)
  5235. New nodes
  5236.                     REAL                IMAGINARY FLAG       ERR
  5237.   0.1240503795052277D+00   0.0000000000000000D+00    0   0.4D-17
  5238.   0.6039731642527837D+00   0.0000000000000000D+00    0   0.6D-17
  5239.  -0.3909285467072722D+00   0.0000000000000000D+00    0   0.6D-17
  5240.   0.9203802858970625D+00   0.0000000000000000D+00    0   0.3D-17
  5241.  -0.8029298284023471D+00   0.0000000000000000D+00    0   0.3D-17
  5242. New full extended expansion
  5243.   0.1000000000000000D+01*P(  5,X)/HI
  5244.   0.8461538461538462D+00*P(  6,X)/HI
  5245. Complete extended rule: STEP= 1  POINTS=  6  IFLAG=0  NODES ADDED=  5
  5246.  No.                     NODE                   WEIGHT
  5247.    1   0.9203802858970625D+00   0.2015883852534808D+00
  5248.    2   0.6039731642527837D+00   0.4169013343119077D+00
  5249.    3   0.1240503795052277D+00   0.5209267831895750D+00
  5250.    4  -0.3909285467072722D+00   0.4853871884689699D+00
  5251.    5  -0.8029298284023471D+00   0.3196407532205109D+00
  5252.    6  -0.1000000000000000D+01   0.5555555555555556D-01
  5253. TEST( 0)=   0.1000000000000000D+01
  5254. TEST( 1)=   0.1000000000000000D+01
  5255. TEST( 2)=   0.1000000000000000D+01
  5256. TEST( 3)=   0.1000000000000000D+01
  5257. TEST( 4)=   0.1000000000000000D+01
  5258. Iteration           2
  5259. Coefficients of expansion whose roots are the new nodes:
  5260.   0.1238920331102971D-01*P(  0,X)
  5261.  -0.1115360783931244D-01*P(  1,X)
  5262.   0.2930949908491627D-01*P(  2,X)
  5263.  -0.2573880815371107D-01*P(  3,X)
  5264.  -0.8051048473617479D+00*P(  4,X)
  5265.  -0.6245367209597196D+00*P(  5,X)
  5266.   0.7380888520433050D+00*P(  6,X)
  5267.   0.1000000000000000D+01*P(  7,X)
  5268. New nodes
  5269.                     REAL                IMAGINARY FLAG       ERR
  5270.  -0.1366416372713493D+00   0.0000000000000000D+00    0   0.9D-18
  5271.  -0.6212165636007762D+00   0.0000000000000000D+00    0   0.4D-17
  5272.   0.3761018966748717D+00   0.0000000000000000D+00    0   0.4D-17
  5273.  -0.8487727816552522D+00   0.0000000000000000D+00    0   0.4D-17
  5274.   0.7905296024586544D+00   0.0000000000000000D+00    0   0.4D-17
  5275.   0.9865012767506534D+00   0.0000000000000000D+00    0   0.2D-17
  5276.  -0.9439342521493506D+00   0.0000000000000000D+00    0   0.2D-17
  5277. New full extended expansion
  5278.  -0.8815438503554517D-01*P(  7,X)/HI
  5279.  -0.8472981649987972D-01*P(  8,X)/HI
  5280.  -0.3768076078707027D+00*P(  9,X)/HI
  5281.  -0.4473580103536859D+00*P( 10,X)/HI
  5282.   0.3851866566831191D+00*P( 11,X)/HI
  5283.   0.1000000000000000D+01*P( 12,X)/HI
  5284.   0.5106460045718307D+00*P( 13,X)/HI
  5285. Complete extended rule: STEP= 2  POINTS= 13  IFLAG=0  NODES ADDED=  7
  5286.  No.                     NODE                   WEIGHT
  5287.    1   0.9865012767506534D+00   0.3610633344712083D-01
  5288.    2   0.9203802858970625D+00   0.9797463317823482D-01
  5289.    3   0.7905296024586544D+00   0.1603549149394082D+00
  5290.    4   0.6039731642527837D+00   0.2100921244820766D+00
  5291.    5   0.3761018966748717D+00   0.2427304474580505D+00
  5292.    6   0.1240503795052277D+00   0.2588076132975782D+00
  5293.    7  -0.1366416372713493D+00   0.2601366692626690D+00
  5294.    8  -0.3909285467072722D+00   0.2455064597946105D+00
  5295.    9  -0.6212165636007762D+00   0.2115512241336131D+00
  5296.   10  -0.8029298284023471D+00   0.1329820397038908D+00
  5297.   11  -0.8487727816552522D+00   0.3616137156650629D-01
  5298.   12  -0.9439342521493506D+00   0.9202712852123144D-01
  5299.   13  -0.1000000000000000D+01   0.1556904021500967D-01
  5300. TEST( 0)=   0.1000000000000000D+01
  5301. TEST( 1)=   0.1000000000000000D+01
  5302. TEST( 2)=   0.1000000000000000D+01
  5303. TEST( 3)=   0.1000000000000000D+01
  5304. TEST( 4)=   0.1000000000000000D+01
  5305. Iteration           3
  5306. Coefficients of expansion whose roots are the new nodes:
  5307.  -0.2568241533603606D+00*P(  0,X)
  5308.   0.6273882318514978D+00*P(  1,X)
  5309.  -0.6950114612492999D+00*P(  2,X)
  5310.   0.3514310704836285D+00*P(  3,X)
  5311.   0.2414864785768811D+00*P(  4,X)
  5312.  -0.9310510552284522D+00*P(  5,X)
  5313.   0.1469801497278645D+01*P(  6,X)
  5314.  -0.5792538945795940D+01*P(  7,X)
  5315.   0.4360460897303821D+01*P(  8,X)
  5316.  -0.1885604119806995D+02*P(  9,X)
  5317.   0.1887338563566692D+01*P( 10,X)
  5318.   0.6992128566633852D+02*P( 11,X)
  5319.  -0.1072921826820173D+02*P( 12,X)
  5320.  -0.4426841333562902D+02*P( 13,X)
  5321.   0.1000000000000000D+01*P( 14,X)
  5322. New nodes
  5323.                     REAL                IMAGINARY FLAG       ERR
  5324.   0.9979162551518678D+00   0.0000000000000000D+00    0   0.1D-16
  5325.  -0.6134267604635425D-02   0.0000000000000000D+00    0   0.1D-16
  5326.   0.9613067296650284D+00   0.0000000000000000D+00    0   0.7D-17
  5327.  -0.2655914229442032D+00   0.0000000000000000D+00    0   0.7D-17
  5328.   0.8632649380482529D+00   0.0000000000000000D+00    0   0.8D-17
  5329.   0.7034887989758216D+00   0.0000000000000000D+00    0   0.8D-17
  5330.   0.4941080138619341D+00   0.0000000000000000D+00    0   0.4D-16
  5331.   0.2520863057103871D+00   0.0000000000000000D+00    0   0.4D-16
  5332.  -0.7205766157140713D+00   0.0000000000000000D+00    0   0.2D-16
  5333.  -0.5103354152259295D+00   0.0000000000000000D+00    0   0.2D-16
  5334.  -0.9812660421998112D+00   0.0000000000000000D+00    0   0.1D-15
  5335.  -0.8923964308975302D+00   0.0000000000000000D+00    0   0.1D-15
  5336.   0.2307179086994016D+02   0.0000000000000000D+00    0   0.6D-16
  5337.  -0.1013669616811477D+01   0.0000000000000000D+00    0   0.6D-16
  5338. New full extended expansion
  5339.   0.5454360425671037D-02*P( 14,X)/HI
  5340.   0.1275790889143820D-02*P( 15,X)/HI
  5341.   0.1362458441982789D-01*P( 16,X)/HI
  5342.   0.1061409558174235D-01*P( 17,X)/HI
  5343.  -0.7800045804654459D-01*P( 18,X)/HI
  5344.  -0.6147544605704888D-01*P( 19,X)/HI
  5345.  -0.2027665031851448D+00*P( 20,X)/HI
  5346.  -0.2559758659655763D+00*P( 21,X)/HI
  5347.   0.5447045628625731D+00*P( 22,X)/HI
  5348.   0.1000000000000000D+01*P( 23,X)/HI
  5349.   0.5759468453196904D-02*P( 24,X)/HI
  5350.  -0.7380381496936674D+00*P( 25,X)/HI
  5351.  -0.3289096723205376D+00*P( 26,X)/HI
  5352.   0.7335603893034949D-02*P( 27,X)/HI
  5353. Complete extended rule: STEP= 3  POINTS= 27  IFLAG=6  NODES ADDED= 14
  5354.  No.                     NODE                   WEIGHT
  5355.    1   0.2307179086994016D+02  -0.1710833635652233D-16
  5356.    2   0.9979162551518678D+00   0.5761238214206027D-02
  5357.    3   0.9865012767506534D+00   0.1781397602627082D-01
  5358.    4   0.9613067296650284D+00   0.3288145280959046D-01
  5359.    5   0.9203802858970625D+00   0.4904105110221086D-01
  5360.    6   0.8632649380482529D+00   0.6509033800352046D-01
  5361.    7   0.7905296024586544D+00   0.8015752890516894D-01
  5362.    8   0.7034887989758216D+00   0.9361527599467614D-01
  5363.    9   0.6039731642527837D+00   0.1050581380411569D+00
  5364.   10   0.4941080138619341D+00   0.1143012662323623D+00
  5365.   11   0.3761018966748717D+00   0.1213546454148586D+00
  5366.   12   0.2520863057103871D+00   0.1263455706105022D+00
  5367.   13   0.1240503795052277D+00   0.1294155830050473D+00
  5368.   14  -0.6134267604635425D-02   0.1306510180165526D+00
  5369.   15  -0.1366416372713493D+00   0.1300525005145075D+00
  5370.   16  -0.2655914229442032D+00   0.1275061882372417D+00
  5371.   17  -0.3909285467072722D+00   0.1227817936161397D+00
  5372.   18  -0.5103354152259295D+00   0.1155996181401652D+00
  5373.   19  -0.6212165636007762D+00   0.1056775942146705D+00
  5374.   20  -0.7205766157140713D+00   0.9232499519844784D-01
  5375.   21  -0.8029298284023471D+00   0.6879140063252571D-01
  5376.   22  -0.8487727816552522D+00   0.3092904062992692D-01
  5377.   23  -0.8923964308975302D+00   0.5477880738383480D-01
  5378.   24  -0.9439342521493506D+00   0.4546365767396098D-01
  5379.   25  -0.9812660421998112D+00   0.2876294640770191D-01
  5380.   26  -0.1000000000000000D+01   0.5992084797070105D-02
  5381.   27  -0.1013669616811477D+01  -0.1477098223165217D-03
  5382. TEST( 0)=   0.1000000000000000D+01
  5383. TEST( 1)=   0.9999999999999862D+00
  5384. TEST( 2)=   0.9999999999727656D+00
  5385. TEST( 3)=   0.9999999436798130D+00
  5386. TEST( 4)=   0.9998820691687861D+00
  5387. Rule test is unsatisfactory
  5388.  
  5389. Case ?:
  5390. 4
  5391.  
  5392. No. of rules?:
  5393. 2
  5394.  
  5395. Gauss-Laguerre 2-point extension
  5396. Iteration           1
  5397. Coefficients of expansion whose roots are the new nodes:
  5398.   0.0000000000000000D+00*P(  0,X)
  5399.   0.0000000000000000D+00*P(  1,X)
  5400.   0.1000000000000000D+01*P(  2,X)
  5401. New nodes
  5402.                     REAL                IMAGINARY FLAG       ERR
  5403.   0.3414213562373095D+01   0.0000000000000000D+00    0   0.0D+00
  5404.   0.5857864376269049D+00   0.0000000000000000D+00    0   0.0D+00
  5405. New full extended expansion
  5406.   0.1000000000000000D+01*P(  2,X)/HI
  5407. Complete extended rule: STEP= 1  POINTS=  2  IFLAG=0  NODES ADDED=  2
  5408.  No.                     NODE                   WEIGHT
  5409.    1   0.3414213562373095D+01   0.1464466094067262D+00
  5410.    2   0.5857864376269049D+00   0.8535533905932737D+00
  5411. TEST( 0)=   0.9999999999999999D+00
  5412. TEST( 1)=   0.1000000000000000D+01
  5413. Iteration           2
  5414. Coefficients of expansion whose roots are the new nodes:
  5415.   0.6000000000000000D+01*P(  0,X)
  5416.  -0.1500000000000000D+01*P(  1,X)
  5417.   0.0000000000000000D+00*P(  2,X)
  5418.   0.1000000000000000D+01*P(  3,X)
  5419. New nodes
  5420.                     REAL                IMAGINARY FLAG       ERR
  5421.   0.8396196974011156D+01   0.0000000000000000D+00    0   0.7D-16
  5422.   0.3019015129944220D+00  -0.1959389276469933D+01    0   0.2D-16
  5423.   0.3019015129944220D+00   0.1959389276469933D+01    0   0.2D-16
  5424. New full extended expansion
  5425.   0.8125000000000000D+00*P(  3,X)/HI
  5426.  -0.1000000000000000D+01*P(  4,X)/HI
  5427.   0.4166666666666667D+00*P(  5,X)/HI
  5428. Complete extended rule: STEP= 2  POINTS=  5  IFLAG=4  NODES ADDED=  3
  5429. Terminated prematurely - see IFLAG
  5430.  
  5431. Case ?:
  5432. 5
  5433.  
  5434. No. of rules?:
  5435. 2
  5436.  
  5437. Gauss-Hermite 3-point extension
  5438. Iteration           1
  5439. Coefficients of expansion whose roots are the new nodes:
  5440.   0.0000000000000000D+00*P(  0,X)
  5441.   0.0000000000000000D+00*P(  1,X)
  5442.   0.0000000000000000D+00*P(  2,X)
  5443.   0.1000000000000000D+01*P(  3,X)
  5444. New nodes
  5445.                     REAL                IMAGINARY FLAG       ERR
  5446.   0.0000000000000000D+00   0.0000000000000000D+00    0   0.0D+00
  5447.   0.1224744871391589D+01   0.0000000000000000D+00    0   0.0D+00
  5448.  -0.1224744871391589D+01   0.0000000000000000D+00    0   0.0D+00
  5449. New full extended expansion
  5450.   0.1000000000000000D+01*P(  3,X)/HI
  5451. Complete extended rule: STEP= 1  POINTS=  3  IFLAG=0  NODES ADDED=  3
  5452.  No.                     NODE                   WEIGHT
  5453.    1   0.1224744871391589D+01   0.2954089751509193D+00
  5454.    2   0.0000000000000000D+00   0.1181635900603677D+01
  5455. TEST( 0)=   0.1000000000000000D+01
  5456. TEST( 1)=   0.1000000000000000D+01
  5457. TEST( 2)=   0.1000000000000000D+01
  5458. Iteration           2
  5459. Coefficients of expansion whose roots are the new nodes:
  5460.  -0.3000000000000000D+01*P(  0,X)
  5461.   0.0000000000000000D+00*P(  1,X)
  5462.  -0.2000000000000000D+01*P(  2,X)
  5463.   0.0000000000000000D+00*P(  3,X)
  5464.   0.1000000000000000D+01*P(  4,X)
  5465. New nodes
  5466.                     REAL                IMAGINARY FLAG       ERR
  5467.   0.0000000000000000D+00  -0.4884800789447105D+00    0   0.0D+00
  5468.   0.0000000000000000D+00   0.4884800789447105D+00    0   0.0D+00
  5469.   0.2288801605103822D+01   0.0000000000000000D+00    0   0.2D-16
  5470.  -0.2288801605103822D+01   0.0000000000000000D+00    0   0.2D-16
  5471. New full extended expansion
  5472.   0.0000000000000000D+00*P(  4,X)/HI
  5473.   0.3809523809523810D+00*P(  5,X)/HI
  5474.   0.0000000000000000D+00*P(  6,X)/HI
  5475.   0.1000000000000000D+01*P(  7,X)/HI
  5476. Complete extended rule: STEP= 2  POINTS=  7  IFLAG=4  NODES ADDED=  4
  5477. Terminated prematurely - see IFLAG
  5478.  
  5479. Case ?:
  5480. 6
  5481.  
  5482. No. of rules?:
  5483. 3
  5484.  
  5485. Gauss-Jacobi 3-point extension
  5486. Iteration           1
  5487. Coefficients of expansion whose roots are the new nodes:
  5488.   0.0000000000000000D+00*P(  0,X)
  5489.   0.0000000000000000D+00*P(  1,X)
  5490.   0.0000000000000000D+00*P(  2,X)
  5491.   0.1000000000000000D+01*P(  3,X)
  5492. New nodes
  5493.                     REAL                IMAGINARY FLAG       ERR
  5494.   0.1647102868965424D+00   0.0000000000000000D+00    0   0.3D-17
  5495.   0.9008058292716294D+00   0.0000000000000000D+00    0   0.4D-17
  5496.   0.5498684992164436D+00   0.0000000000000000D+00    0   0.4D-17
  5497. New full extended expansion
  5498.   0.1000000000000000D+01*P(  3,X)/HI
  5499. Complete extended rule: STEP= 1  POINTS=  3  IFLAG=0  NODES ADDED=  3
  5500.  No.                     NODE                   WEIGHT
  5501.    1   0.9008058292716294D+00   0.2332816246559149D+00
  5502.    2   0.5498684992164436D+00   0.3076023676819127D+00
  5503.    3   0.1647102868965424D+00   0.1257826743288388D+00
  5504. TEST( 0)=   0.9999999999999998D+00
  5505. TEST( 1)=   0.9999999999999998D+00
  5506. TEST( 2)=   0.1000000000000000D+01
  5507. Iteration           2
  5508. Coefficients of expansion whose roots are the new nodes:
  5509.   0.8302544967323833D-04*P(  0,X)
  5510.   0.1808212463080860D-03*P(  1,X)
  5511.  -0.6293935530868694D-01*P(  2,X)
  5512.   0.0000000000000000D+00*P(  3,X)
  5513.   0.1000000000000000D+01*P(  4,X)
  5514. New nodes
  5515.                     REAL                IMAGINARY FLAG       ERR
  5516.   0.3434982475781609D+00   0.0000000000000000D+00    0   0.2D-17
  5517.   0.4317458752763439D-01   0.0000000000000000D+00    0   0.2D-17
  5518.   0.9829837529243084D+00   0.0000000000000000D+00    0   0.8D-17
  5519.   0.7479904707934259D+00   0.0000000000000000D+00    0   0.8D-17
  5520. New full extended expansion
  5521.  -0.1000000000000000D+01*P(  4,X)/HI
  5522.  -0.7540286168214371D+00*P(  5,X)/HI
  5523.  -0.9004851826770350D+00*P(  6,X)/HI
  5524.   0.5021708298937920D+00*P(  7,X)/HI
  5525. Complete extended rule: STEP= 2  POINTS=  7  IFLAG=0  NODES ADDED=  4
  5526.  No.                     NODE                   WEIGHT
  5527.    1   0.9829837529243084D+00   0.4509009780887507D-01
  5528.    2   0.9008058292716294D+00   0.1136674496440606D+00
  5529.    3   0.7479904707934259D+00   0.1567638583107757D+00
  5530.    4   0.5498684992164436D+00   0.1546815936593538D+00
  5531.    5   0.3434982475781609D+00   0.1161056548660293D+00
  5532.    6   0.1647102868965424D+00   0.6270539664794700D-01
  5533.    7   0.4317458752763439D-01   0.1765261572962525D-01
  5534. TEST( 0)=   0.1000000000000000D+01
  5535. TEST( 1)=   0.1000000000000000D+01
  5536. TEST( 2)=   0.1000000000000000D+01
  5537. TEST( 3)=   0.1000000000000000D+01
  5538. TEST( 4)=   0.1000000000000000D+01
  5539. Iteration           3
  5540. Coefficients of expansion whose roots are the new nodes:
  5541.   0.1246085068908996D-07*P(  0,X)
  5542.   0.5106502089882409D-07*P(  1,X)
  5543.   0.1857830431079363D-06*P(  2,X)
  5544.   0.3154953497851658D-04*P(  3,X)
  5545.   0.3729410486893128D-03*P(  4,X)
  5546.   0.6566133154308339D-02*P(  5,X)
  5547.  -0.6845782043616039D-01*P(  6,X)
  5548.  -0.1121555778222753D+00*P(  7,X)
  5549.   0.1000000000000000D+01*P(  8,X)
  5550. New nodes
  5551.                     REAL                IMAGINARY FLAG       ERR
  5552.   0.9522115224106390D-01   0.0000000000000000D+00    0   0.2D-16
  5553.   0.1092616002586163D-01   0.0000000000000000D+00    0   0.2D-16
  5554.   0.4453534840434267D+00   0.0000000000000000D+00    0   0.5D-17
  5555.   0.2486386449037345D+00   0.0000000000000000D+00    0   0.5D-17
  5556.   0.8321177481736263D+00   0.0000000000000000D+00    0   0.7D-18
  5557.   0.6523614224614975D+00   0.0000000000000000D+00    0   0.7D-18
  5558.   0.9973759430379304D+00   0.0000000000000000D+00    0   0.1D-16
  5559.   0.9513731441472555D+00   0.0000000000000000D+00    0   0.1D-16
  5560. New full extended expansion
  5561.  -0.1000000000000000D+01*P(  8,X)/HI
  5562.  -0.7219216410522186D+00*P(  9,X)/HI
  5563.  -0.4137098497966033D+00*P( 10,X)/HI
  5564.   0.6243456378913302D+00*P( 11,X)/HI
  5565.   0.2379858019599160D+00*P( 12,X)/HI
  5566.   0.3071737360122939D+00*P( 13,X)/HI
  5567.  -0.3226631546888718D+00*P( 14,X)/HI
  5568.   0.5874911786061134D-01*P( 15,X)/HI
  5569. Complete extended rule: STEP= 3  POINTS= 15  IFLAG=0  NODES ADDED=  8
  5570.  No.                     NODE                   WEIGHT
  5571.    1   0.9973759430379304D+00   0.7250785857083849D-02
  5572.    2   0.9829837529243084D+00   0.2225370714572648D-01
  5573.    3   0.9513731441472555D+00   0.4003272827656301D-01
  5574.    4   0.9008058292716294D+00   0.5689076367068382D-01
  5575.    5   0.8321177481736263D+00   0.7021992138795099D-01
  5576.    6   0.7479904707934259D+00   0.7836602038520848D-01
  5577.    7   0.6523614224614975D+00   0.8066055699011988D-01
  5578.    8   0.5498684992164436D+00   0.7734675361301653D-01
  5579.    9   0.4453534840434267D+00   0.6936411431773201D-01
  5580.   10   0.3434982475781609D+00   0.5805035560699054D-01
  5581.   11   0.2486386449037345D+00   0.4488514434457869D-01
  5582.   12   0.1647102868965424D+00   0.3135360123263908D-01
  5583.   13   0.9522115224106390D-01   0.1889127817157171D-01
  5584.   14   0.4317458752763439D-01   0.8826110122443174D-02
  5585.   15   0.1092616002586163D-01   0.2274825544359364D-02
  5586. TEST( 0)=   0.1000000000000001D+01
  5587. TEST( 1)=   0.1000000000000004D+01
  5588. TEST( 2)=   0.1000000000000006D+01
  5589. TEST( 3)=   0.1000000000000009D+01
  5590. TEST( 4)=   0.1000000000000013D+01
  5591.  
  5592.